diff --git a/postgrest.cabal b/postgrest.cabal index 93ee8a633..2312e4434 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -54,6 +54,7 @@ library , configurator , containers , contravariant + , either , hasql , hasql-pool == 0.4.1 , hasql-transaction == 0.4.5.1 diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 367831a33..05743d7da 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -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 @@ -33,6 +46,7 @@ type RequestBody = BL.ByteString data Action = ActionCreate | ActionRead | ActionUpdate | ActionDelete | ActionInfo | ActionInvoke + | ActionInspect | ActionInappropriate deriving Eq -- | The target db object of a user action @@ -40,6 +54,7 @@ data Target = TargetIdent QualifiedIdentifier | TargetProc QualifiedIdentifier | TargetRoot | TargetUnknown [Text] + deriving Eq -- | How to return the inserted data data PreferRepresentation = Full | HeadersOnly | None deriving Eq -- @@ -47,15 +62,17 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI | CTAny | CTOther BS.ByteString deriving Eq -ctToHeader :: ContentType -> Header -ctToHeader ct = (hContentType, toHeader ct <> "; charset=utf-8") +-- | Convert from ContentType to a full HTTP Header +toHeader :: ContentType -> Header +toHeader ct = (hContentType, toMime ct <> "; charset=utf-8") -toHeader :: ContentType -> ByteString -toHeader CTApplicationJSON = "application/json" -toHeader CTTextCSV = "text/csv" -toHeader CTOpenAPI = "application/openapi+json" -toHeader CTAny = "*/*" -toHeader (CTOther ct) = ct +-- | Convert from ContentType to a ByteString representing the mime type +toMime :: ContentType -> ByteString +toMime CTApplicationJSON = "application/json" +toMime CTTextCSV = "text/csv" +toMime CTOpenAPI = "application/openapi+json" +toMime CTAny = "*/*" +toMime (CTOther ct) = ct {-| Describes what the user wants to do. This data type is a @@ -104,7 +121,9 @@ userApiRequest schema req reqBody = else ActionInappropriate else case method of - "GET" -> ActionRead + "GET" -> if target == TargetRoot + then ActionInspect + else ActionRead "POST" -> ActionCreate "PATCH" -> ActionUpdate "DELETE" -> ActionDelete @@ -137,7 +156,7 @@ userApiRequest schema req reqBody = . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody ct -> - PayloadParseError $ "Content-Type not acceptable: " <> toHeader ct + PayloadParseError $ "Content-Type not acceptable: " <> toMime ct relevantPayload = case action of ActionCreate -> Just payload ActionUpdate -> Just payload @@ -281,6 +300,3 @@ ensureUniform arr = if (V.length objs == V.length arr) && areKeysUniform then Just (UniformObjects objs) else Nothing - -readBSMaybe :: Read a => ByteString -> Maybe a -readBSMaybe = readMaybe . toS diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index f3e898371..007b28429 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -15,6 +15,7 @@ import Data.Ranged.Ranges (emptyRange) import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate) import Data.Time.Clock.POSIX (POSIXTime) import Data.Tree +import Data.Either.Combinators (mapLeft) import qualified Hasql.Pool as P import qualified Hasql.Transaction as HT @@ -38,13 +39,14 @@ import qualified Hasql.Transaction as H import qualified Data.HashMap.Strict as M -import PostgREST.ApiRequest (ApiRequest(..), ContentType(..) - , Action(..), Target(..) - , PreferRepresentation (..) - , userApiRequest, mutuallyAgreeable - , ctToHeader - , userApiRequest - , toHeader) +import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) + , Action(..), Target(..) + , PreferRepresentation (..) + , mutuallyAgreeable + , toHeader + , userApiRequest + , toMime + ) import PostgREST.Auth (jwtClaims, containsRole) import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure @@ -98,201 +100,206 @@ transactionMode _ = HT.Write app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response 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) -> - serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType -> - case readSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ toS e - Right (q, cq) -> do - let singular = iPreferSingular apiRequest - stm = createReadStatement q cq singular - shouldCount (contentType == CTTextCSV) - respondToRange $ do - row <- H.query () stm - let (tableTotal, queryTotal, _ , body) = row - if singular - then return $ if queryTotal <= 0 - then responseLBS status404 [] "" - else responseLBS status200 [ctToHeader contentType] (toS body) - else do - let (status, contentRange) = rangeHeader queryTotal tableTotal - canonical = iCanonicalQS apiRequest - return $ responseLBS status - [ctToHeader contentType, contentRange, - ("Content-Location", - "/" <> toS (qiName qi) <> - if BS.null canonical then "" else "?" <> toS canonical - ) - ] (toS body) + (ActionRead, TargetIdent qi, Nothing) -> + case readSqlParts of + Left errorResponse -> return errorResponse + Right (q, cq) -> respondToRange $ do + let singular = iPreferSingular apiRequest + stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV) + row <- H.query () stm + let (tableTotal, queryTotal, _ , body) = row + if singular + then return $ if queryTotal <= 0 + then notFound + else responseLBS status200 [toHeader contentType] (toS body) + else do + let (status, contentRange) = rangeHeader queryTotal tableTotal + canonical = iCanonicalQS apiRequest + --TargetIdent qi = iTarget apiRequest + return $ responseLBS status + [toHeader contentType, contentRange, + ("Content-Location", + "/" <> toS (qiName qi) <> + if BS.null canonical then "" else "?" <> toS canonical + ) + ] (toS body) - (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), - Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> - serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType -> - case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ toS e - Right (sq,mq) -> do - let isSingle = (==1) $ V.length rows - when (not isSingle && iPreferSingular apiRequest) $ - HT.sql [P6.q| DO $$ - BEGIN RAISE EXCEPTION cardinality_violation - USING MESSAGE = - '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 - row <- H.query uniform stm - let (_, _, fs, body) = extractQueryResult row - headers = catMaybes [ - if null fs - then Nothing - else Just (hLocation, "/" <> toS table <> renderLocationFields fs) - , if iPreferRepresentation apiRequest == Full - then Just $ ctToHeader contentType - else Nothing - , Just . contentRangeH 1 0 $ - toInteger <$> if shouldCount then Just (V.length rows) else Nothing - ] + (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> + case mutateSqlParts of + Left errorResponse -> return errorResponse + Right (sq, mq) -> do + let isSingle = (==1) $ V.length rows + when (not isSingle && iPreferSingular apiRequest) $ + HT.sql [P6.q| DO $$ + BEGIN RAISE EXCEPTION cardinality_violation + USING MESSAGE = + '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 + row <- H.query uniform stm + let (_, _, fs, body) = extractQueryResult row + headers = catMaybes [ + if null fs + then Nothing + else Just (hLocation, "/" <> toS table <> renderLocationFields fs) + , if iPreferRepresentation apiRequest == Full + then Just $ toHeader contentType + else Nothing + , Just . contentRangeH 1 0 $ + toInteger <$> if shouldCount then Just (V.length rows) else Nothing + ] - return . responseLBS status201 headers $ - if iPreferRepresentation apiRequest == Full - then toS body else "" + return . responseLBS status201 headers $ + if iPreferRepresentation apiRequest == Full + then toS body else "" - (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> - serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType -> - case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ toS e - Right (sq,mq) -> do - let singular = iPreferSingular apiRequest - stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload - row <- H.query uniform stm - let (_, queryTotal, _, body) = extractQueryResult row - when (singular && queryTotal > 1) $ - HT.sql [P6.q| DO $$ - BEGIN RAISE EXCEPTION cardinality_violation - USING MESSAGE = - 'plurality=singular specified, but more than one object would be updated'; - END $$; - |] - let r = contentRangeH 0 (toInteger $ queryTotal-1) - (toInteger <$> if shouldCount then Just queryTotal else Nothing) - s = case () of _ | queryTotal == 0 -> status404 - | iPreferRepresentation apiRequest == Full -> status200 - | otherwise -> status204 - return $ if iPreferRepresentation apiRequest == Full - then responseLBS s [ctToHeader contentType, r] (toS body) - else responseLBS s [r] "" + (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> + case mutateSqlParts of + Left errorResponse -> return errorResponse + Right (sq, mq) -> do + let singular = iPreferSingular apiRequest + stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload + row <- H.query uniform stm + let (_, queryTotal, _, body) = extractQueryResult row + when (singular && queryTotal > 1) $ + HT.sql [P6.q| DO $$ + BEGIN RAISE EXCEPTION cardinality_violation + USING MESSAGE = + 'plurality=singular specified, but more than one object would be updated'; + END $$; + |] + let r = contentRangeH 0 (toInteger $ queryTotal-1) + (toInteger <$> if shouldCount then Just queryTotal else Nothing) + s = case () of _ | queryTotal == 0 -> status404 + | iPreferRepresentation apiRequest == Full -> status200 + | otherwise -> status204 + return $ if iPreferRepresentation apiRequest == Full + then responseLBS s [toHeader contentType, r] (toS body) + else responseLBS s [r] "" - (ActionDelete, TargetIdent qi, Nothing) -> - serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType -> - case mutateSqlParts of - Left e -> return $ responseLBS status400 [jsonH] $ toS e - Right (sq,mq) -> do - let emptyUniform = UniformObjects V.empty - fakeload = PayloadJSON emptyUniform - stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload - row <- H.query emptyUniform stm - let (_, queryTotal, _, body) = extractQueryResult row - r = contentRangeH 1 0 $ - toInteger <$> if shouldCount then Just queryTotal else Nothing - return $ if queryTotal == 0 - then notFound - else if iPreferRepresentation apiRequest == Full - then responseLBS status200 [ctToHeader contentType, r] (toS body) - else responseLBS status204 [r] "" + (ActionDelete, TargetIdent qi, Nothing) -> + case mutateSqlParts of + Left errorResponse -> return errorResponse + Right (sq, mq) -> do + let emptyUniform = UniformObjects V.empty + fakeload = PayloadJSON emptyUniform + stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload + row <- H.query emptyUniform stm + let (_, queryTotal, _, body) = extractQueryResult row + r = contentRangeH 1 0 $ + toInteger <$> if shouldCount then Just queryTotal else Nothing + return $ if queryTotal == 0 + then notFound + else if iPreferRepresentation apiRequest == Full + then responseLBS status200 [toHeader contentType, r] (toS body) + else responseLBS status204 [r] "" - (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> - let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in - case mTable of - Nothing -> return notFound - Just table -> - let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in - return $ responseLBS status200 [allOrigins, acceptH] "" + (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) -> + let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in + case mTable of + Nothing -> return notFound + Just table -> + let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in + return $ responseLBS status200 [allOrigins, acceptH] "" - (ActionInvoke, TargetProc qi, - Just (PayloadJSON (UniformObjects payload))) -> do - let p = V.head payload - 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) - let (tableTotal, queryTotal, body) = - fromMaybe (Just 0, 0, emptyArray) row - (status, contentRange) = rangeHeader queryTotal tableTotal - return $ responseLBS status [jsonH, contentRange] (toS . encode $ body) + (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> + case readSqlParts of + Left errorResponse -> return errorResponse + Right (q, cq) -> respondToRange $ do + let p = V.head payload + singular = iPreferSingular apiRequest + row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular) + let (tableTotal, queryTotal, body) = + fromMaybe (Just 0, 0, emptyArray) row + (status, contentRange) = rangeHeader queryTotal tableTotal + return $ responseLBS status [jsonH, contentRange] (toS . encode $ body) - (ActionRead, TargetRoot, Nothing) -> do - let host = configHost conf - port = toInteger $ configPort conf - proxy = pickProxy $ toS <$> configProxyUri conf - uri Nothing = ("http", host, port, "/") - uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) - uri' = uri proxy - encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri' - serves [CTOpenAPI] (iAccepts apiRequest) $ \_ -> do - body <- encodeApi . toTableInfo <$> H.query schema accessibleTables - return $ responseLBS status200 [openapiH] $ toS body + (ActionInspect, TargetRoot, Nothing) -> do + let host = configHost conf + port = toInteger $ configPort conf + proxy = pickProxy $ toS <$> configProxyUri conf + uri Nothing = ("http", host, port, "/") + uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b) + uri' = uri proxy + encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri' + body <- encodeApi . toTableInfo <$> H.query schema accessibleTables + return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body - (ActionInappropriate, _, _) -> return $ responseLBS status405 [] "" + (_, _, Just (PayloadParseError e)) -> + return $ errResponse status400 $ + toS (formatGeneralError "Cannot parse request payload" (toS e)) - (_, _, Just (PayloadParseError e)) -> - return $ responseLBS status400 [jsonH] $ - toS (formatGeneralError "Cannot parse request payload" (toS e)) + _ -> return notFound - (_, 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 - 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 = ctToHeader CTApplicationJSON - openapiH = ctToHeader CTOpenAPI - schema = toS $ configSchema conf - shouldCount = iPreferCount apiRequest - topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest - mapSnd f (a, b) = (a, f b) - readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest - 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 +responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType +responseContentTypeOrError accepts action = + 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 + Nothing -> do + let failed = intercalate ", " $ map (toS . toMime) cAccepts + Left $ errResponse status415 $ + "None of these Content-Types are available: " <> failed + Just ct -> Right ct splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) splitKeyValue kv = (k, BS.tail v) @@ -372,11 +379,12 @@ treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` re nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) -buildReadRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Text ReadRequest -buildReadRequest maxRows allRels allProcs apiRequest = +readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest +readRequest maxRows allRels allProcs apiRequest = + mapLeft (errResponse status400) $ treeRestrictRange maxRows =<< augumentRequestWithJoin schema relations =<< - first formatParserError readRequest + first formatParserError parseReadRequest where (schema, rootTableName) = fromJust $ -- Make it safe let target = iTarget apiRequest in @@ -395,8 +403,8 @@ buildReadRequest maxRows allRels allProcs apiRequest = action :: Action action = iAction apiRequest - readRequest :: Either ParseError ReadRequest - readRequest = addFiltersOrdersRanges apiRequest <*> + parseReadRequest :: Either ParseError ReadRequest + parseReadRequest = addFiltersOrdersRanges apiRequest <*> parse (pRequestSelect rootName) ("failed to parse select parameter <<" <> toS selStr <> ">>") (toS selStr) where selStr = iSelect apiRequest @@ -413,12 +421,13 @@ buildReadRequest maxRows allRels allProcs apiRequest = _ -> allRels where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation -buildMutateRequest :: ApiRequest -> Either Text MutateRequest -buildMutateRequest apiRequest = case action of - ActionCreate -> Insert rootTableName <$> pure payload - ActionUpdate -> Update rootTableName <$> pure payload <*> filters - ActionDelete -> Delete rootTableName <$> filters - _ -> Left "Unsupported HTTP verb" +mutateRequest :: ApiRequest -> Either Response MutateRequest +mutateRequest apiRequest = mapLeft (errResponse status400) $ + case action of + ActionCreate -> Insert rootTableName <$> pure payload + ActionUpdate -> Update rootTableName <$> pure payload <*> filters + ActionDelete -> Delete rootTableName <$> filters + _ -> Left "Unsupported HTTP verb" where action = iAction apiRequest payload = fromJust $ iPayload apiRequest diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 84cbb14e2..be4c2b1ac 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -12,17 +12,17 @@ import qualified Hasql.Pool as P import qualified Hasql.Session as H import qualified Network.HTTP.Types.Status as HT import Network.Wai (Response, responseLBS) -import PostgREST.ApiRequest (ctToHeader, ContentType(..)) +import PostgREST.ApiRequest (toHeader, ContentType(..)) errResponse :: HT.Status -> Text -> Response errResponse status message = responseLBS status - [ctToHeader CTApplicationJSON] + [toHeader CTApplicationJSON] (toS $ T.concat ["{\"message\":\"",message,"\"}"]) pgErrResponse :: Bool -> P.UsageError -> Response pgErrResponse authed e = let status = httpStatus authed e - jsonType = ctToHeader CTApplicationJSON + jsonType = toHeader CTApplicationJSON wwwAuth = ("WWW-Authenticate", "Bearer") hdrs = if status == HT.status401 then [jsonType, wwwAuth] diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 9232cb88e..0c70f8887 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -15,7 +15,7 @@ import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Static (only, staticPolicy) import PostgREST.ApiRequest (ApiRequest(..), ContentType(..), - ctToHeader) + toHeader) import PostgREST.Auth (claimsToSQL, JWTAttempt(..)) import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Error (errResponse) @@ -40,7 +40,7 @@ runWithClaims conf eClaims app req = anon = String . toS $ configAnonRole conf customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf unauthed message = responseLBS unauthorized401 - [ ctToHeader CTApplicationJSON + [ toHeader CTApplicationJSON , ( "WWW-Authenticate" , "Bearer error=\"invalid_token\", " <> "error_description=\"" <> message <> "\"" diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs index bf43f3689..0d619f569 100644 --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -20,14 +20,14 @@ import Protolude hiding (concat, (&), Proxy, get, interca import Data.Swagger -import PostgREST.ApiRequest (ContentType(..), toHeader) +import PostgREST.ApiRequest (ContentType(..), toMime) import PostgREST.Config (prettyVersion) import PostgREST.QueryBuilder (operators) import PostgREST.Types (Table(..), Column(..), PgArg(..), Proxy(..), ProcDescription(..)) 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" = SwaggerString