refactor moving findProc into ApiRequest to allow parsing parameters differently by proc

2020-10-26 17:49:51 -05:00
parent 06e85357c7
commit 18cc214c04
5 changed files with 91 additions and 81 deletions
@@ -2,8 +2,9 @@
 Module      : PostgREST.ApiRequest
 Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
 -}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE LambdaCase     #-}
+{-# LANGUAGE MultiWayIf     #-}
+{-# LANGUAGE NamedFieldPuns #-}

 module PostgREST.ApiRequest (
  ApiRequest(..)
@@ -45,6 +46,7 @@ import Web.Cookie                (parseCookiesText)
 import Data.Ranged.Boundaries

 import PostgREST.Error      (ApiRequestError (..))
+import PostgREST.Parsers    (pRequestColumns)
 import PostgREST.RangeQuery (NonnegRange, allRange, rangeGeq,
                             rangeLimit, rangeOffset, rangeRequested,
                             restrictRange)
@@ -63,7 +65,7 @@ data Action = ActionCreate       | ActionRead{isHead :: Bool}
            deriving Eq
 -- | The target db object of a user action
 data Target = TargetIdent QualifiedIdentifier
-            | TargetProc{tpQi :: QualifiedIdentifier, tpIsRootSpec :: Bool}
+            | TargetProc{tProc :: ProcDescription, tpIsRootSpec :: Bool}
            | TargetDefaultSpec{tdsSchema :: Schema} -- The default spec offered at root "/"
            | TargetUnknown [Text]
            deriving Eq
@@ -90,7 +92,7 @@ data ApiRequest = ApiRequest {
  , iLogic                :: [(Text, Text)]                   -- ^ &and and &or parameters used for complex boolean logic
  , iSelect               :: Maybe Text                       -- ^ &select parameter used to shape the response
  , iOnConflict           :: Maybe Text                       -- ^ &on_conflict parameter used to upsert on specific unique keys
-  , iColumns              :: Maybe Text                       -- ^ &columns parameter used to shape the payload
+  , iColumns              :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
  , iOrder                :: [(Text, Text)]                   -- ^ &order parameters for each level
  , iCanonicalQS          :: ByteString                       -- ^ Alphabetized (canonical) request query string for response URLs
  , iJWT                  :: Text                             -- ^ JSON Web Token
@@ -103,12 +105,13 @@ data ApiRequest = ApiRequest {
  }

 -- | Examines HTTP request and translates it into user intent.
-userApiRequest :: NonEmpty Schema -> Maybe Text -> Request -> RequestBody -> Either ApiRequestError ApiRequest
-userApiRequest confSchemas rootSpec req reqBody
+userApiRequest :: NonEmpty Schema -> Maybe Text -> DbStructure -> Request -> RequestBody -> Either ApiRequestError ApiRequest
+userApiRequest confSchemas rootSpec dbStructure req reqBody
  | isJust profile && fromJust profile `notElem` confSchemas = Left $ UnacceptableSchema $ toList confSchemas
  | isTargetingProc && method `notElem` ["HEAD", "GET", "POST"] = Left ActionInappropriate
  | topLevelRange == emptyRange = Left InvalidRange
  | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) witness payload
+  | isLeft parsedColumns = either Left witness parsedColumns
  | otherwise = Right ApiRequest {
      iAction = action
      , iTarget = target
@@ -131,7 +134,7 @@ userApiRequest confSchemas rootSpec req reqBody
      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
      , iSelect = toS <$> join (lookup "select" qParams)
      , iOnConflict = toS <$> join (lookup "on_conflict" qParams)
-      , iColumns = columns
+      , iColumns = payloadColumns
      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
      , iCanonicalQS = toS $ urlEncodeVars
        . L.sortOn fst
@@ -174,6 +177,12 @@ userApiRequest confSchemas rootSpec req reqBody
  columns
    | action `elem` [ActionCreate, ActionUpdate, ActionInvoke InvPost] = toS <$> join (lookup "columns" qParams)
    | otherwise = Nothing
+  parsedColumns = pRequestColumns columns
+  payloadColumns =
+    case (relevantPayload, fromRight Nothing parsedColumns) of
+      (Just ProcessedJSON{pjKeys}, _) -> pjKeys
+      (Just RawJSON{}, Just cls)      -> cls
+      _                               -> S.empty
  payload =
    case (contentType, action) of
      (_, ActionInvoke InvGet)  -> Right rpcPrmsToJson
@@ -226,13 +235,17 @@ userApiRequest confSchemas rootSpec req reqBody
      = Just $ maybe defaultSchema toS $ lookupHeader "Accept-Profile"
    | otherwise = Nothing
  schema = fromMaybe defaultSchema profile
-  target = case path of
-    []            -> case rootSpec of
-                       Just pName -> TargetProc (QualifiedIdentifier schema pName) True
-                       Nothing    -> TargetDefaultSpec schema
-    [table]       -> TargetIdent $ QualifiedIdentifier schema table
-    ["rpc", proc] -> TargetProc (QualifiedIdentifier schema proc) False
-    other         -> TargetUnknown other
+  target =
+    let
+      callFindProc proc = findProc (QualifiedIdentifier schema proc) payloadColumns (hasPrefer (show SingleObject)) $ dbProcs dbStructure
+    in
+    case path of
+      []             -> case rootSpec of
+                        Just pName -> TargetProc (callFindProc pName) True
+                        Nothing    -> TargetDefaultSpec schema
+      [table]        -> TargetIdent $ QualifiedIdentifier schema table
+      ["rpc", pName] -> TargetProc (callFindProc pName) False
+      other          -> TargetUnknown other

  shouldParsePayload =
    action `elem`
@@ -50,7 +50,6 @@ import PostgREST.Error            (PgError (..), SimpleError (..),
                                   errorResponseFor, singularityError)
 import PostgREST.Middleware
 import PostgREST.OpenAPI
-import PostgREST.Parsers          (pRequestColumns)
 import PostgREST.QueryBuilder     (limitedQuery, mutateRequestToQuery,
                                   readRequestToCountQuery,
                                   readRequestToQuery,
@@ -76,12 +75,10 @@ postgrest logLev refConf refDbStructure pool getTime connWorker =
      Nothing -> respond . errorResponseFor $ ConnectionLostError
      Just dbStructure -> do
        response <- do
-          let apiReq = userApiRequest (configSchemas conf) (configRootSpec conf) req body
-              -- Need to parse ?columns early because findProc needs it to solve overloaded functions.
-              apiReqCols = (,) <$> apiReq <*> (pRequestColumns . iColumns =<< apiReq)
-          case apiReqCols of
+          let apiReq = userApiRequest (configSchemas conf) (configRootSpec conf) dbStructure req body
+          case apiReq of
            Left err -> return . errorResponseFor $ err
-            Right (apiRequest, maybeCols) -> do
+            Right apiRequest -> do
              -- The jwt must be checked before touching the db.
              attempt <- attemptJwtClaims (configJWKS conf) (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)
              case jwtClaims attempt of
@@ -89,38 +86,27 @@ postgrest logLev refConf refDbStructure pool getTime connWorker =
                Right claims -> do
                  let
                    authed = containsRole claims
-                    cols = case (iPayload apiRequest, maybeCols) of
-                      (Just ProcessedJSON{pjKeys}, _) -> pjKeys
-                      (Just RawJSON{}, Just cls)      -> cls
-                      _                               -> S.empty
-                    proc = case iTarget apiRequest of
-                      TargetProc qi _ -> findProc qi cols (iPreferParameters apiRequest == Just SingleObject) $ dbProcs dbStructure
-                      _ -> Nothing
-                    handleReq = runPgLocals conf claims (app dbStructure proc cols conf) apiRequest
-                    txMode = transactionMode proc (iAction apiRequest)
-                  dbResp <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
+                    handleReq = runPgLocals conf claims (app dbStructure conf) apiRequest
+                  dbResp <- P.use pool $ HT.transaction HT.ReadCommitted (txMode apiRequest) handleReq
                  return $ either (errorResponseFor . PgError authed) identity dbResp
        -- Launch the connWorker when the connection is down. The postgrest function can respond successfully(with a stale schema cache) before the connWorker is done.
        when (responseStatus response == status503) connWorker
        respond response

-transactionMode :: Maybe ProcDescription -> Action -> HT.Mode
-transactionMode proc action =
-  case action of
-    ActionRead _         -> HT.Read
-    ActionInfo           -> HT.Read
-    ActionInspect _      -> HT.Read
-    ActionInvoke InvGet  -> HT.Read
-    ActionInvoke InvHead -> HT.Read
-    ActionInvoke InvPost ->
-      let v = maybe Volatile pdVolatility proc in
-      if v == Stable || v == Immutable
-         then HT.Read
-         else HT.Write
+txMode :: ApiRequest -> HT.Mode
+txMode apiRequest =
+  case (iAction apiRequest, iTarget apiRequest) of
+    (ActionRead _        , _) -> HT.Read
+    (ActionInfo          , _) -> HT.Read
+    (ActionInspect _     , _) -> HT.Read
+    (ActionInvoke InvGet , _) -> HT.Read
+    (ActionInvoke InvHead, _) -> HT.Read
+    (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Stable} _)    -> HT.Read
+    (ActionInvoke InvPost, TargetProc ProcDescription{pdVolatility=Immutable} _) -> HT.Read
    _ -> HT.Write

-app :: DbStructure -> Maybe ProcDescription -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response
-app dbStructure proc cols conf apiRequest =
+app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
+app dbStructure conf apiRequest =
  let rawContentTypes = (decodeContentType <$> configRawMediaTypes conf) `L.union` [ CTOctetStream, CTTextPlain ] in
  case responseContentTypeOrError (iAccepts apiRequest) rawContentTypes (iAction apiRequest) (iTarget apiRequest) of
    Left errorResponse -> return errorResponse
@@ -210,7 +196,7 @@ app dbStructure proc cols conf apiRequest =
                Left err -> return $ errorResponseFor err
                Right (ghdrs, gstatus) -> do
                  let
-                    updateIsNoOp = S.null cols
+                    updateIsNoOp = S.null (iColumns apiRequest)
                    defStatus | queryTotal == 0 && not updateIsNoOp      = status404
                              | iPreferRepresentation apiRequest == Full = status200
                              | otherwise                                = status204
@@ -294,14 +280,14 @@ app dbStructure proc cols conf apiRequest =
                  allOrigins = ("Access-Control-Allow-Origin", "*") :: Header in
              return $ responseLBS status200 [allOrigins, allowH] mempty

-        (ActionInvoke invMethod, TargetProc qi@(QualifiedIdentifier tSchema pName) _, Just pJson) ->
-          let tName = fromMaybe pName $ procTableName =<< proc in
-          case readSqlParts tSchema tName of
+        (ActionInvoke invMethod, TargetProc proc@ProcDescription{pdSchema, pdName} _, Just pJson) ->
+          let tName = fromMaybe pdName $ procTableName proc in
+          case readSqlParts pdSchema tName of
            Left errorResponse -> return errorResponse
            Right (q, cq, bField, returning) -> do
              let
                preferParams = iPreferParameters apiRequest
-                pq = requestToCallProcQuery qi (specifiedProcArgs cols proc) returnsScalar preferParams returning
+                pq = requestToCallProcQuery (QualifiedIdentifier pdSchema pdName) (specifiedProcArgs (iColumns apiRequest) proc) returnsScalar preferParams returning
                stm = callProcStatement returnsScalar pq q cq shouldCount (contentType == CTSingularJSON)
                        (contentType == CTTextCSV) (contentType `elem` rawContentTypes) (preferParams == Just MultipleObjects)
                        bField pgVer
@@ -351,7 +337,10 @@ app dbStructure proc cols conf apiRequest =
        plannedCount = iPreferCount apiRequest == Just PlannedCount
        shouldCount = exactCount || estimatedCount
        topLevelRange = iTopLevelRange apiRequest
-        returnsScalar = maybe False procReturnsScalar proc
+        returnsScalar =
+          case iTarget apiRequest of
+            TargetProc proc _ -> procReturnsScalar proc
+            _                 -> False
        pgVer = pgVersion dbStructure
        profileH = contentProfileH <$> iProfile apiRequest

@@ -370,7 +359,7 @@ app dbStructure proc cols conf apiRequest =
        mutateSqlParts s t =
          let
            readReq = readRequest s t maxRows (dbRelations dbStructure) apiRequest
-            mutReq = mutateRequest s t apiRequest cols (tablePKCols dbStructure s t) =<< readReq
+            mutReq = mutateRequest s t apiRequest (tablePKCols dbStructure s t) =<< readReq
          in
          (,) <$>
          (readRequestToQuery <$> readReq) <*>
@@ -287,15 +287,15 @@ addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =
  where
    pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest

-mutateRequest :: Schema -> TableName -> ApiRequest -> S.Set FieldName -> [FieldName] -> ReadRequest -> Either Response MutateRequest
-mutateRequest schema tName apiRequest cols pkCols readReq = mapLeft errorResponseFor $
+mutateRequest :: Schema -> TableName -> ApiRequest -> [FieldName] -> ReadRequest -> Either Response MutateRequest
+mutateRequest schema tName apiRequest pkCols readReq = mapLeft errorResponseFor $
  case action of
    ActionCreate -> do
        confCols <- case iOnConflict apiRequest of
            Nothing    -> pure pkCols
            Just param -> pRequestOnConflict param
-        pure $ Insert qi cols ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
-    ActionUpdate -> Update qi cols <$> combinedLogic <*> pure returnings
+        pure $ Insert qi (iColumns apiRequest) ((,) <$> iPreferResolution apiRequest <*> Just confCols) [] returnings
+    ActionUpdate -> Update qi (iColumns apiRequest) <$> combinedLogic <*> pure returnings
    ActionSingleUpsert ->
      (\flts ->
        if null (iLogic apiRequest) &&
@@ -304,7 +304,7 @@ mutateRequest schema tName apiRequest cols pkCols readReq = mapLeft errorRespons
           all (\case
              Filter _ (OpExpr False (Op "eq" _)) -> True
              _ -> False) flts
-          then Insert qi cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
+          then Insert qi (iColumns apiRequest) (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
        else
          Left InvalidFilters) =<< filters
    ActionDelete -> Delete qi <$> combinedLogic <*> pure returnings
@@ -157,13 +157,17 @@ type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
  An overloaded function can have a different volatility or even a different return type.
  Ideally, handling overloaded functions should be left to pg itself. But we need to know certain proc attributes in advance.
 -}
-findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> Maybe ProcDescription
-findProc qi payloadKeys paramsAsSingleObject allProcs =
-  case M.lookup qi allProcs of
-    Nothing     -> Nothing
-    Just [proc] -> Just proc           -- if it's not an overloaded function then immediately get the ProcDescription
-    Just procs  -> find matches procs  -- Handle overloaded functions case
+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> ProcsMap -> ProcDescription
+findProc qi payloadKeys paramsAsSingleObject allProcs = fromMaybe fallback bestMatch
  where
+    -- instead of passing Maybe ProcDescription around, we create a fallback description here when we can't find a matching function
+    -- args is empty, but because "specifiedProcArgs" will fill the missing arguments with default type text, this is not a problem
+    fallback = ProcDescription (qiSchema qi) (qiName qi) Nothing mempty (SetOf $ Composite $ QualifiedIdentifier "" "record") Volatile
+    bestMatch =
+      case M.lookup qi allProcs of
+        Nothing     -> Nothing
+        Just [proc] -> Just proc           -- if it's not an overloaded function then immediately get the ProcDescription
+        Just procs  -> find matches procs  -- Handle overloaded functions case
    matches proc =
      if paramsAsSingleObject
        -- if the arg is not of json type let the db give the err
@@ -174,12 +178,9 @@ findProc qi payloadKeys paramsAsSingleObject allProcs =
  Search the procedure parameters by matching them with the specified keys.
  If the key doesn't match a parameter, a parameter with a default type "text" is assumed.
 -}
-specifiedProcArgs :: S.Set FieldName -> Maybe ProcDescription -> [PgArg]
+specifiedProcArgs :: S.Set FieldName -> ProcDescription -> [PgArg]
 specifiedProcArgs keys proc =
-  let
-    args = maybe [] pdArgs proc
-  in
-  (\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) args)) <$> S.toList keys
+  (\k -> fromMaybe (PgArg k "text" True) (find ((==) k . pgaName) (pdArgs proc))) <$> S.toList keys

 procReturnsScalar :: ProcDescription -> Bool
 procReturnsScalar proc = case proc of
@@ -511,19 +511,26 @@ spec actualPgVersion =
          `shouldRespondWith` [json|{ "p1": "1", "p2": "text"}|]
          { matchHeaders = [matchContentTypeJson] }

-    it "should work with an overloaded function" $ do
-      get "/rpc/overloaded" `shouldRespondWith`
-        [json|[{ "overloaded": 1 },
-               { "overloaded": 2 },
-               { "overloaded": 3 }]|]
-        { matchHeaders = [matchContentTypeJson] }
-      request methodPost "/rpc/overloaded" [("Prefer","params=single-object")]
-        [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]
-       `shouldRespondWith`
-        [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]
-        { matchHeaders = [matchContentTypeJson] }
-      get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|]
-      get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [str|"123"|]
+    context "should work with an overloaded function" $ do
+      it "overloaded()" $
+        get "/rpc/overloaded" `shouldRespondWith`
+          [json|[{ "overloaded": 1 },
+                 { "overloaded": 2 },
+                 { "overloaded": 3 }]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "overloaded(json) single-object" $
+        request methodPost "/rpc/overloaded" [("Prefer","params=single-object")]
+          [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]
+         `shouldRespondWith`
+          [json|[{"x": 1, "y": "first"}, {"x": 2, "y": "second"}]|]
+          { matchHeaders = [matchContentTypeJson] }
+
+      it "overloaded(int, int)" $
+        get "/rpc/overloaded?a=1&b=2" `shouldRespondWith` [str|3|]
+
+      it "overloaded(text, text, text)" $
+        get "/rpc/overloaded?a=1&b=2&c=3" `shouldRespondWith` [str|"123"|]

    context "only for POST rpc" $ do
      it "gives a parse filter error if GET style proc args are specified" $