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
+209 -200
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
@@ -38,13 +39,14 @@ import qualified Hasql.Transaction as H
import qualified Data.HashMap.Strict as M 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,201 +100,206 @@ 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 (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
Left errorResponse -> return errorResponse
Right contentType ->
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 errorResponse -> return errorResponse
Left e -> return $ responseLBS status400 [jsonH] $ toS e Right (q, cq) -> respondToRange $ do
Right (q, cq) -> do let singular = iPreferSingular apiRequest
let singular = iPreferSingular apiRequest stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV)
stm = createReadStatement q cq singular row <- H.query () stm
shouldCount (contentType == CTTextCSV) let (tableTotal, queryTotal, _ , body) = row
respondToRange $ do if singular
row <- H.query () stm then return $ if queryTotal <= 0
let (tableTotal, queryTotal, _ , body) = row then notFound
if singular else responseLBS status200 [toHeader contentType] (toS body)
then return $ if queryTotal <= 0 else do
then responseLBS status404 [] "" let (status, contentRange) = rangeHeader queryTotal tableTotal
else responseLBS status200 [ctToHeader contentType] (toS body) canonical = iCanonicalQS apiRequest
else do --TargetIdent qi = iTarget apiRequest
let (status, contentRange) = rangeHeader queryTotal tableTotal return $ responseLBS status
canonical = iCanonicalQS apiRequest [toHeader contentType, contentRange,
return $ responseLBS status ("Content-Location",
[ctToHeader contentType, contentRange, "/" <> toS (qiName qi) <>
("Content-Location", if BS.null canonical then "" else "?" <> toS canonical
"/" <> toS (qiName qi) <> )
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))) -> case mutateSqlParts of
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType -> Left errorResponse -> return errorResponse
case mutateSqlParts of Right (sq, mq) -> do
Left e -> return $ responseLBS status400 [jsonH] $ toS e let isSingle = (==1) $ V.length rows
Right (sq,mq) -> do when (not isSingle && iPreferSingular apiRequest) $
let isSingle = (==1) $ V.length rows HT.sql [P6.q| DO $$
when (not isSingle && iPreferSingular apiRequest) $ BEGIN RAISE EXCEPTION cardinality_violation
HT.sql [P6.q| DO $$ USING MESSAGE =
BEGIN RAISE EXCEPTION cardinality_violation 'plurality=singular specified, but more than one object would be inserted';
USING MESSAGE = END $$;
'plurality=singular specified, but more than one object would be inserted'; |]
END $$; 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 qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload
let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? row <- H.query uniform stm
let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload let (_, _, fs, body) = extractQueryResult row
row <- H.query uniform stm headers = catMaybes [
let (_, _, fs, body) = extractQueryResult row if null fs
headers = catMaybes [ then Nothing
if null fs else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
then Nothing , if iPreferRepresentation apiRequest == Full
else Just (hLocation, "/" <> toS table <> renderLocationFields fs) then Just $ toHeader contentType
, if iPreferRepresentation apiRequest == Full else Nothing
then Just $ ctToHeader contentType , Just . contentRangeH 1 0 $
else Nothing toInteger <$> if shouldCount then Just (V.length rows) else Nothing
, Just . contentRangeH 1 0 $ ]
toInteger <$> if shouldCount then Just (V.length rows) else Nothing
]
return . responseLBS status201 headers $ return . responseLBS status201 headers $
if iPreferRepresentation apiRequest == Full if iPreferRepresentation apiRequest == Full
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 errorResponse -> return errorResponse
Left e -> return $ responseLBS status400 [jsonH] $ toS e 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 row <- H.query uniform stm
row <- H.query uniform stm let (_, queryTotal, _, body) = extractQueryResult row
let (_, queryTotal, _, body) = extractQueryResult row when (singular && queryTotal > 1) $
when (singular && queryTotal > 1) $ HT.sql [P6.q| DO $$
HT.sql [P6.q| DO $$ BEGIN RAISE EXCEPTION cardinality_violation
BEGIN RAISE EXCEPTION cardinality_violation USING MESSAGE =
USING MESSAGE = 'plurality=singular specified, but more than one object would be updated';
'plurality=singular specified, but more than one object would be updated'; END $$;
END $$; |]
|] let r = contentRangeH 0 (toInteger $ queryTotal-1)
let r = contentRangeH 0 (toInteger $ queryTotal-1) (toInteger <$> if shouldCount then Just queryTotal else Nothing)
(toInteger <$> if shouldCount then Just queryTotal else Nothing) s = case () of _ | queryTotal == 0 -> status404
s = case () of _ | queryTotal == 0 -> status404 | 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 [toHeader contentType, r] (toS body)
then responseLBS s [ctToHeader 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 errorResponse -> return errorResponse
Left e -> return $ responseLBS status400 [jsonH] $ toS e Right (sq, mq) -> do
Right (sq,mq) -> do let emptyUniform = UniformObjects V.empty
let emptyUniform = UniformObjects V.empty fakeload = PayloadJSON emptyUniform
fakeload = PayloadJSON emptyUniform stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload
stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload row <- H.query emptyUniform stm
row <- H.query emptyUniform stm let (_, queryTotal, _, body) = extractQueryResult row
let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $
r = contentRangeH 1 0 $ toInteger <$> if shouldCount then Just queryTotal else Nothing
toInteger <$> if shouldCount then Just queryTotal else Nothing 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 [toHeader contentType, r] (toS body)
then responseLBS status200 [ctToHeader contentType, r] (toS body) else responseLBS status204 [r] ""
else responseLBS status204 [r] ""
(ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
case mTable of case mTable of
Nothing -> return notFound Nothing -> return notFound
Just table -> Just table ->
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
let p = V.head payload Left errorResponse -> return errorResponse
singular = iPreferSingular apiRequest Right (q, cq) -> respondToRange $ do
serves [CTApplicationJSON] (iAccepts apiRequest) $ \_ -> case readSqlParts of let p = V.head payload
Left e -> return $ responseLBS status400 [jsonH] $ toS e singular = iPreferSingular apiRequest
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
uri Nothing = ("http", host, port, "/") uri Nothing = ("http", host, port, "/")
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 [toHeader CTOpenAPI] $ toS body
return $ responseLBS status200 [openapiH] $ toS body
(ActionInappropriate, _, _) -> return $ responseLBS status405 [] "" (_, _, Just (PayloadParseError e)) ->
return $ errResponse status400 $
toS (formatGeneralError "Cannot parse request payload" (toS e))
(_, _, Just (PayloadParseError e)) -> _ -> return notFound
return $ responseLBS status400 [jsonH] $
toS (formatGeneralError "Cannot parse request payload" (toS e))
(_, TargetUnknown _, _) -> return notFound where
toTableInfo :: [Table] -> [(Table, [Column], [Text])]
toTableInfo = map (\t ->
let tSchema = tableSchema t
tTable = tableName t
cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
in (t, cols, pkeys))
notFound = responseLBS status404 [] ""
filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
filterCol :: Schema -> TableName -> Column -> Bool
filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
filterCol _ _ _ = False
allPrKeys = dbPrimaryKeys dbStructure
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
jsonH = toHeader CTApplicationJSON
shouldCount = iPreferCount apiRequest
schema = toS $ configSchema conf
topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
rangeHeader queryTotal tableTotal =
let lower = rangeOffset topLevelRange
upper = lower + toInteger queryTotal - 1
contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
status = rangeStatus lower upper (toInteger <$> tableTotal)
in (status, contentRange)
(_, _, _) -> return notFound 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
where responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
toTableInfo :: [Table] -> [(Table, [Column], [Text])] responseContentTypeOrError accepts action =
toTableInfo = map (\t -> case action of
let tSchema = tableSchema t ActionInappropriate -> Left $ errResponse status405 "Unsupported HTTP verb"
tTable = tableName t _ -> serves contentTypesForRequest accepts
cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure where
pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys contentTypesForRequest =
in case action of
(t, cols, pkeys)) ActionRead -> [CTApplicationJSON, CTTextCSV]
notFound = responseLBS status404 [] "" ActionCreate -> [CTApplicationJSON, CTTextCSV]
filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk ActionUpdate -> [CTApplicationJSON, CTTextCSV]
filterCol :: Schema -> TableName -> Column -> Bool ActionDelete -> [CTApplicationJSON, CTTextCSV]
filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb ActionInvoke -> [CTApplicationJSON]
filterCol _ _ _ = False ActionInspect -> [CTOpenAPI]
allPrKeys = dbPrimaryKeys dbStructure ActionInfo -> [CTTextCSV]
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header ActionInappropriate -> []
jsonH = ctToHeader CTApplicationJSON serves sProduces cAccepts =
openapiH = ctToHeader CTOpenAPI case mutuallyAgreeable sProduces cAccepts of
schema = toS $ configSchema conf Nothing -> do
shouldCount = iPreferCount apiRequest let failed = intercalate ", " $ map (toS . toMime) cAccepts
topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest Left $ errResponse status415 $
mapSnd f (a, b) = (a, f b) "None of these Content-Types are available: " <> failed
readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest Just ct -> Right ct
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
contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
status = rangeStatus lower upper (toInteger <$> tableTotal)
in (status, contentRange)
serves :: Monad m => [ContentType] -> [ContentType] ->
(ContentType -> m Response) -> m Response
serves sProduces cAccepts resp =
case mutuallyAgreeable sProduces cAccepts of
Nothing -> do
let failed = intercalate ", " $ map (toS . toHeader) cAccepts
return $ errResponse status415 $
"None of these Content-Types are available: " <> failed
Just ct -> resp 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,12 +421,13 @@ 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) $
ActionCreate -> Insert rootTableName <$> pure payload case action of
ActionUpdate -> Update rootTableName <$> pure payload <*> filters ActionCreate -> Insert rootTableName <$> pure payload
ActionDelete -> Delete rootTableName <$> filters ActionUpdate -> Update rootTableName <$> pure payload <*> filters
_ -> Left "Unsupported HTTP verb" ActionDelete -> Delete rootTableName <$> filters
_ -> Left "Unsupported HTTP verb"
where where
action = iAction apiRequest action = iAction apiRequest
payload = fromJust $ iPayload apiRequest payload = fromJust $ iPayload apiRequest
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