From 47c4fbc8ef06452c2caa1f563cec796f9e3b308c Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:54:23 -0500 Subject: [PATCH] Introduce the type ApiRequestError and make userApiRequest return an Either ApiRequestError ApiRequest --- src/PostgREST/ApiRequest.hs | 155 +++++++++++++++++++----------------- src/PostgREST/App.hs | 27 ++++--- src/PostgREST/Types.hs | 3 +- 3 files changed, 98 insertions(+), 87 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 30fef3380..73043cb70 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -3,6 +3,7 @@ Module : PostgREST.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -} module PostgREST.ApiRequest ( ApiRequest(..) + , ApiRequestError(..) , ContentType(..) , Action(..) , Target(..) @@ -62,6 +63,8 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI | CTAny | CTOther BS.ByteString deriving Eq +data ApiRequestError = ErrorActionInappropriate | ErrorInvalidBody ByteString deriving (Show, Eq) + -- | Convert from ContentType to a full HTTP Header toHeader :: ContentType -> Header toHeader ct = (hContentType, toMime ct <> "; charset=utf-8") @@ -113,84 +116,86 @@ data ApiRequest = ApiRequest { } -- | Examines HTTP request and translates it into user intent. -userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest -userApiRequest schema req reqBody = - let action = - if isTargetingProc - then - if method == "POST" - then ActionInvoke - else ActionInappropriate - else - case method of - "GET" -> if target == TargetRoot - then ActionInspect - else ActionRead - "POST" -> ActionCreate - "PATCH" -> ActionUpdate - "DELETE" -> ActionDelete - "OPTIONS" -> ActionInfo - _ -> ActionInappropriate - target = case path of - [] -> TargetRoot - [table] -> TargetIdent - $ QualifiedIdentifier schema table - ["rpc", proc] -> TargetProc - $ QualifiedIdentifier schema proc - other -> TargetUnknown other - payload = case decodeContentType - . fromMaybe "application/json" - $ lookupHeader "content-type" of - CTApplicationJSON -> - either (PayloadParseError . toS) - (\val -> case ensureUniform (pluralize val) of - Nothing -> PayloadParseError "All object keys must match" - Just json -> PayloadJSON json) - (JSON.eitherDecode reqBody) - CTTextCSV -> - either (PayloadParseError . toS) - (\val -> case ensureUniform (csvToJson val) of - Nothing -> PayloadParseError "All lines must have same number of fields" - Just json -> PayloadJSON json) - (CSV.decodeByName reqBody) - CTOther "application/x-www-form-urlencoded" -> - PayloadJSON . UniformObjects . V.singleton . M.fromList - . map (toS *** JSON.String . toS) . parseSimpleQuery - $ toS reqBody - ct -> - PayloadParseError $ "Content-Type not acceptable: " <> toMime ct - relevantPayload = case action of - ActionCreate -> Just payload - ActionUpdate -> Just payload - ActionInvoke -> Just payload - _ -> Nothing in - - ApiRequest { - iAction = action - , iTarget = target - , iRange = ranges - , iAccepts = fromMaybe [CTAny] $ - map decodeContentType . parseHttpAccept <$> lookupHeader "accept" - , iPayload = relevantPayload - , iPreferRepresentation = representation - , iPreferSingular = singular - , iPreferSingleObjectParameter = singleObject - , iPreferCount = not singular && hasPrefer "count=exact" - , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ] - , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams - , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] - , iCanonicalQS = toS $ urlEncodeVars - . L.sortBy (comparing fst) - . map (join (***) toS) - . parseSimpleQuery - $ rawQueryString req - , iJWT = tokenStr - } - +userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest +userApiRequest schema req reqBody + | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate + | isError = Left $ ErrorInvalidBody payloadError + | otherwise = Right ApiRequest { + iAction = action + , iTarget = target + , iRange = ranges + , iAccepts = fromMaybe [CTAny] $ + map decodeContentType . parseHttpAccept <$> lookupHeader "accept" + , iPayload = relevantPayload + , iPreferRepresentation = representation + , iPreferSingular = singular + , iPreferSingleObjectParameter = singleObject + , iPreferCount = not singular && hasPrefer "count=exact" + , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ] + , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams + , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] + , iCanonicalQS = toS $ urlEncodeVars + . L.sortBy (comparing fst) + . map (join (***) toS) + . parseSimpleQuery + $ rawQueryString req + , iJWT = tokenStr + } where + isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path + payloadError = case payload of + PayloadParseError err -> err + _ -> "" + isError = case relevantPayload of + Just (PayloadParseError _) -> True + _ -> False + payload = + case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of + CTApplicationJSON -> + either (PayloadParseError . toS) + (\val -> case ensureUniform (pluralize val) of + Nothing -> PayloadParseError "All object keys must match" + Just json -> PayloadJSON json) + (JSON.eitherDecode reqBody) + CTTextCSV -> + either (PayloadParseError . toS) + (\val -> case ensureUniform (csvToJson val) of + Nothing -> PayloadParseError "All lines must have same number of fields" + Just json -> PayloadJSON json) + (CSV.decodeByName reqBody) + CTOther "application/x-www-form-urlencoded" -> + PayloadJSON . UniformObjects . V.singleton . M.fromList + . map (toS *** JSON.String . toS) . parseSimpleQuery + $ toS reqBody + ct -> + PayloadParseError $ "Content-Type not acceptable: " <> toMime ct + action = + if isTargetingProc + then ActionInvoke + else + case method of + "GET" -> if target == TargetRoot + then ActionInspect + else ActionRead + "POST" -> ActionCreate + "PATCH" -> ActionUpdate + "DELETE" -> ActionDelete + "OPTIONS" -> ActionInfo + _ -> ActionInappropriate + target = case path of + [] -> TargetRoot + [table] -> TargetIdent + $ QualifiedIdentifier schema table + ["rpc", proc] -> TargetProc + $ QualifiedIdentifier schema proc + other -> TargetUnknown other + relevantPayload = case action of + ActionCreate -> Just payload + ActionUpdate -> Just payload + ActionInvoke -> Just payload + _ -> Nothing path = pathInfo req method = requestMethod req - isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path hdrs = requestHeaders req qParams = [(toS k, v)|(k,v) <- queryString req] lookupHeader = flip lookup hdrs diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 3f0ba8d8b..a2a89dab3 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -40,6 +40,7 @@ import qualified Hasql.Transaction as H import qualified Data.HashMap.Strict as M import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) + , ApiRequestError(..) , Action(..), Target(..) , PreferRepresentation (..) , mutuallyAgreeable @@ -81,17 +82,23 @@ postgrest conf refDbStructure pool getTime = body <- strictRequestBody req dbStructure <- readIORef refDbStructure - let schema = toS $ configSchema conf - apiRequest = userApiRequest schema req body - eClaims = jwtClaims - (secret <$> configJwtSecret conf) (iJWT apiRequest) time - authed = containsRole eClaims - handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest - txMode = transactionMode $ iAction apiRequest + case userApiRequest (configSchema conf) req body of + Left err -> respond $ respondToError err + Right apiRequest -> do + let eClaims = jwtClaims + (secret <$> configJwtSecret conf) (iJWT apiRequest) time + authed = containsRole eClaims + handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest + txMode = transactionMode $ iAction apiRequest - resp <- either (pgErrResponse authed) id <$> P.use pool - (HT.run handleReq HT.ReadCommitted txMode) - respond resp + resp <- either (pgErrResponse authed) id <$> P.use pool + (HT.run handleReq HT.ReadCommitted txMode) + respond resp + where + respondToError error = + case error of + ErrorActionInappropriate -> errResponse status405 "Bad Request" + ErrorInvalidBody errorMessage -> errResponse status400 $ toS errorMessage transactionMode :: Action -> H.Mode transactionMode ActionRead = HT.Read diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 52a592077..8348d50a1 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -2,7 +2,6 @@ module PostgREST.Types where import Protolude import qualified GHC.Show import Data.Aeson -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Tree import qualified Data.Vector as V @@ -112,7 +111,7 @@ unUniformObjects (UniformObjects objs) = objs -- have a special payload just for CSV, but until -- then CSV is converted to a JSON array. data Payload = PayloadJSON UniformObjects - | PayloadParseError BS.ByteString + | PayloadParseError ByteString deriving (Show, Eq) data Proxy = Proxy {