From 36dbd09459d43cb3355de9b0884ca7f89ab08da8 Mon Sep 17 00:00:00 2001 From: monacoremo <59358383+monacoremo@users.noreply.github.com> Date: Sun, 7 Nov 2021 16:16:24 +0100 Subject: [PATCH] refactor: Remove Protolude.Conv from ApiRequest --- src/PostgREST/Request/ApiRequest.hs | 39 +++++++++++++++-------------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/src/PostgREST/Request/ApiRequest.hs b/src/PostgREST/Request/ApiRequest.hs index 51f79eaaa..223547e56 100644 --- a/src/PostgREST/Request/ApiRequest.hs +++ b/src/PostgREST/Request/ApiRequest.hs @@ -17,7 +17,7 @@ module PostgREST.Request.ApiRequest ) where import qualified Data.Aeson as JSON -import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI import qualified Data.Csv as CSV @@ -25,12 +25,13 @@ import qualified Data.HashMap.Strict as M import qualified Data.List as L import qualified Data.Set as S import qualified Data.Text as T +import qualified Data.Text.Encoding as T import qualified Data.Vector as V +import qualified Data.List.NonEmpty as NonEmptyList import Control.Arrow ((***)) import Data.Aeson.Types (emptyArray, emptyObject) import Data.List (last, lookup, partition, union) -import Data.List.NonEmpty (head) import Data.Maybe (fromJust) import Data.Ranged.Boundaries (Boundary (..)) import Data.Ranged.Ranges (Range (..), emptyRange, @@ -68,8 +69,7 @@ import PostgREST.Request.Preferences (PreferCount (..), import qualified PostgREST.ContentType as ContentType import qualified PostgREST.Request.Preferences as Preferences -import Protolude hiding (head, toS) -import Protolude.Conv (toS) +import Protolude type RequestBody = LBS.ByteString @@ -184,7 +184,7 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody | isJust profile && fromJust profile `notElem` configDbSchemas = Left $ UnacceptableSchema $ toList configDbSchemas | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate | topLevelRange == emptyRange = Left InvalidRange - | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload + | shouldParsePayload && isLeft payload = either (Left . InvalidBody) witness payload | isLeft parsedColumns = either Left witness parsedColumns | otherwise = do acceptContentType <- findAcceptContentType conf action path accepts @@ -206,9 +206,9 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody , iOnConflict = toS <$> join (lookup "on_conflict" qParams) , iColumns = payloadColumns , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] - , iCanonicalQS = toS $ urlEncodeVars + , iCanonicalQS = BS.pack $ urlEncodeVars . L.sortOn fst - . map (join (***) toS . second (fromMaybe BS.empty)) + . map (join (***) BS.unpack . second (fromMaybe mempty)) $ qString , iJWT = tokenStr , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie] @@ -254,11 +254,12 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody case (contentType, action) of (_, ActionInvoke InvGet) -> S.fromList $ fst <$> rpcQParams (_, ActionInvoke InvHead) -> S.fromList $ fst <$> rpcQParams - (CTUrlEncoded, _) -> S.fromList $ map (toS . fst) $ parseSimpleQuery $ toS reqBody + (CTUrlEncoded, _) -> S.fromList $ map (T.decodeUtf8 . fst) $ parseSimpleQuery $ LBS.toStrict reqBody _ -> case (relevantPayload, fromRight Nothing parsedColumns) of (Just ProcessedJSON{payKeys}, _) -> payKeys (Just RawJSON{}, Just cls) -> cls _ -> S.empty + payload :: Either ByteString Payload payload = case contentType of CTApplicationJSON -> if isJust columns @@ -266,17 +267,17 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody else note "All object keys must match" . payloadAttributes reqBody =<< if LBS.null reqBody && isTargetingProc then Right emptyObject - else JSON.eitherDecode reqBody + else first BS.pack $ JSON.eitherDecode reqBody CTTextCSV -> do - json <- csvToJson <$> CSV.decodeByName reqBody + json <- csvToJson <$> first BS.pack (CSV.decodeByName reqBody) note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json CTUrlEncoded -> - let paramsMap = M.fromList $ (toS *** JSON.String . toS) <$> parseSimpleQuery (toS reqBody) in + let paramsMap = M.fromList $ (T.decodeUtf8 *** JSON.String . T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody) in Right $ ProcessedJSON (JSON.encode paramsMap) $ S.fromList (M.keys paramsMap) ct -> if isTargetingProc && ct `elem` [CTTextPlain, CTOctetStream] then Right $ RawPay reqBody - else Left $ toS $ "Content-Type not acceptable: " <> ContentType.toMime ct + else Left $ "Content-Type not acceptable: " <> ContentType.toMime ct topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges -- if no limit is specified, get all the request rows action = case method of @@ -297,7 +298,7 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody "OPTIONS" -> ActionInfo _ -> ActionInspect{isHead=False} - defaultSchema = head configDbSchemas + defaultSchema = NonEmptyList.head configDbSchemas profile | length configDbSchemas <= 1 -- only enable content negotiation by profile when there are multiple schemas specified in the config = Nothing @@ -310,8 +311,8 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody ActionInvoke InvPost -> contentProfile _ -> acceptProfile where - contentProfile = Just $ maybe defaultSchema toS $ lookupHeader "Content-Profile" - acceptProfile = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile" + contentProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Content-Profile" + acceptProfile = Just $ maybe defaultSchema T.decodeUtf8 $ lookupHeader "Accept-Profile" schema = fromMaybe defaultSchema profile target = let @@ -334,7 +335,7 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody -- to store the query string arguments to the function. (_, ActionInvoke InvGet) -> targetToJsonRpcParams (rightToMaybe target) rpcQParams (_, ActionInvoke InvHead) -> targetToJsonRpcParams (rightToMaybe target) rpcQParams - (CTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (toS *** toS) <$> parseSimpleQuery (toS reqBody) + (CTUrlEncoded, ActionInvoke InvPost) -> targetToJsonRpcParams (rightToMaybe target) $ (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody) _ | shouldParsePayload -> rightToMaybe payload | otherwise -> Nothing path = @@ -348,11 +349,11 @@ userApiRequest conf@AppConfig{..} dbStructure req reqBody _ -> PathUnknown method = requestMethod req hdrs = requestHeaders req - qParams = [(toS k, v)|(k,v) <- qString] + qParams = [(T.decodeUtf8 k, T.decodeUtf8 <$> v)|(k,v) <- qString] lookupHeader = flip lookup hdrs Preferences.Preferences{..} = Preferences.fromHeaders hdrs auth = fromMaybe "" $ lookupHeader hAuthorization - tokenStr = case T.split (== ' ') (toS auth) of + tokenStr = case T.split (== ' ') (T.decodeUtf8 auth) of ("Bearer" : t : _) -> t ("bearer" : t : _) -> t _ -> "" @@ -410,7 +411,7 @@ csvToJson (_, vals) = M.map (\str -> if str == "NULL" then JSON.Null - else JSON.String $ toS str + else JSON.String . T.decodeUtf8 $ LBS.toStrict str ) payloadAttributes :: RequestBody -> JSON.Value -> Maybe Payload