refactor: add CallQuery type

Shortens requestToCallProcQuery, which should generate SQL in a more
direct way.

src/PostgREST/App.hs

@@ -429,25 +429,17 @@ handleInvoke invMethod proc context@RequestContext{..} = do
         (pdSchema proc)
         (fromMaybe (pdName proc) $ Proc.procTableName proc)
 
-    returnsSingle (ApiRequest.TargetProc target _) = Proc.procReturnsSingle target
-    returnsSingle _                                = False
-
   req <- readRequest identifier context
   bField <- binaryField context req
 
+  let callReq = ReqBuilder.callRequest proc ctxApiRequest req
+
   (tableTotal, queryTotal, body, gucHeaders, gucStatus) <-
     lift . SQL.statement mempty $
       Statements.callProcStatement
-        (returnsScalar iTarget)
+        (Proc.procReturnsScalar proc)
-        (returnsSingle iTarget)
+        (Proc.procReturnsSingle proc)
-        (QueryBuilder.requestToCallProcQuery
+        (QueryBuilder.requestToCallProcQuery callReq)
-          (QualifiedIdentifier (pdSchema proc) (pdName proc))
-          (Proc.specifiedProcParams iColumns proc)
-          iPayload
-          (returnsScalar iTarget)
-          iPreferParameters
-          (ReqBuilder.returningCols req [])
-        )
         (QueryBuilder.readRequestToQuery req)
         (QueryBuilder.readRequestToCountQuery req)
         (shouldCount iPreferCount)

src/PostgREST/DbStructure/Proc.hs

@@ -11,15 +11,12 @@ module PostgREST.DbStructure.Proc
   , procReturnsScalar
   , procReturnsSingle
   , procTableName
-  , specifiedProcParams
   ) where
 
 import qualified Data.Aeson          as JSON
 import qualified Data.HashMap.Strict as M
-import qualified Data.Set            as S
 
-import PostgREST.DbStructure.Identifiers (FieldName,
+import PostgREST.DbStructure.Identifiers (QualifiedIdentifier (..),
-                                          QualifiedIdentifier (..),
                                           Schema, TableName)
 
 import Protolude
@@ -70,14 +67,6 @@ instance Ord ProcDescription where
 -- | It uses a HashMap for a faster lookup.
 type ProcsMap = M.HashMap QualifiedIdentifier [ProcDescription]
 
-{-|
-  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.
--}
-specifiedProcParams :: S.Set FieldName -> ProcDescription -> [ProcParam]
-specifiedProcParams keys proc =
-  (\k -> fromMaybe (ProcParam k "text" True False) (find ((==) k . ppName) (pdParams proc))) <$> S.toList keys
-
 procReturnsScalar :: ProcDescription -> Bool
 procReturnsScalar proc = case proc of
   ProcDescription{pdReturnType = (Single Scalar)} -> True

src/PostgREST/Query/QueryBuilder.hs

@@ -21,15 +21,12 @@ import qualified Hasql.DynamicStatements.Snippet as H
 
 import Data.Tree (Tree (..))
 
-import PostgREST.DbStructure.Identifiers  (FieldName,
+import PostgREST.DbStructure.Identifiers  (QualifiedIdentifier (..))
-                                           QualifiedIdentifier (..))
 import PostgREST.DbStructure.Proc         (ProcParam (..))
 import PostgREST.DbStructure.Relationship (Cardinality (..),
                                            Relationship (..))
 import PostgREST.DbStructure.Table        (Table (..))
-import PostgREST.Request.ApiRequest       (PayloadJSON (..))
+import PostgREST.Request.Preferences      (PreferResolution (..))
-import PostgREST.Request.Preferences      (PreferParameters (..),
-                                           PreferResolution (..))
 
 import PostgREST.Query.SqlFragment
 import PostgREST.Request.Types
@@ -118,38 +115,34 @@ mutateRequestToQuery (Delete mainQi logicForest returnings) =
   (if null logicForest then mempty else "WHERE " <> intercalateSnippet " AND " (map (pgFmtLogicTree mainQi) logicForest)) <> " " <>
   H.sql (returningF mainQi returnings)
 
-requestToCallProcQuery :: QualifiedIdentifier -> [ProcParam] -> Maybe PayloadJSON -> Bool -> Maybe PreferParameters -> [FieldName] -> H.Snippet
+requestToCallProcQuery :: CallRequest -> H.Snippet
-requestToCallProcQuery qi procParams pj returnsScalar preferParams returnings =
+requestToCallProcQuery (FunctionCall qi params args returnsScalar multipleCall singleParam returnings) =
-  prmsCTE <> sourceBody
+  prmsCTE <> argsBody
   where
-    body = pjRaw <$> pj
+    (prmsCTE, argFrag)
-    paramsAsSingleObject    = preferParams == Just SingleObject
+      | null params = (mempty, mempty)
-    paramsAsMultipleObjects = preferParams == Just MultipleObjects
+      | singleParam = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder args)
-
-    (prmsCTE, args)
-      | null procParams = (mempty, mempty)
-      | paramsAsSingleObject = ("WITH pgrst_args AS (SELECT NULL)", jsonPlaceHolder body)
       | otherwise = (
-          "WITH " <> normalizedBody body <> ", " <>
+          "WITH " <> normalizedBody args <> ", " <>
           H.sql (
             BS.unwords [
             "pgrst_args AS (",
               "SELECT * FROM json_to_recordset(" <> selectBody <> ") AS _(" <> fmtParams (const mempty) (\a -> " " <> encodeUtf8 (ppType a)) <> ")",
             ")"])
-         , H.sql $ if paramsAsMultipleObjects
+         , H.sql $ if multipleCall
              then fmtParams varadicPrefix (\a -> " := pgrst_args." <> pgFmtIdent (ppName a))
              else fmtParams varadicPrefix (\a -> " := (SELECT " <> pgFmtIdent (ppName a) <> " FROM pgrst_args LIMIT 1)")
         )
 
     fmtParams :: (ProcParam -> SqlFragment) -> (ProcParam -> SqlFragment) -> SqlFragment
-    fmtParams prmFragPre prmFragSuf = BS.intercalate ", " ((\a -> prmFragPre a <> pgFmtIdent (ppName a) <> prmFragSuf a) <$> procParams)
+    fmtParams prmFragPre prmFragSuf = BS.intercalate ", " ((\a -> prmFragPre a <> pgFmtIdent (ppName a) <> prmFragSuf a) <$> params)
 
     varadicPrefix :: ProcParam -> SqlFragment
     varadicPrefix a = if ppVar a then "VARIADIC " else mempty
 
-    sourceBody :: H.Snippet
+    argsBody :: H.Snippet
-    sourceBody
+    argsBody
-      | paramsAsMultipleObjects =
+      | multipleCall =
           if returnsScalar
             then "SELECT " <> callIt <> " AS pgrst_scalar FROM pgrst_args"
             else "SELECT pgrst_lat_args.* FROM pgrst_args, " <>
@@ -160,7 +153,7 @@ requestToCallProcQuery qi procParams pj returnsScalar preferParams returnings =
             else "SELECT " <> returnedColumns <> " FROM " <> callIt
 
     callIt :: H.Snippet
-    callIt = H.sql (fromQi qi) <> "(" <> args <> ")"
+    callIt = H.sql (fromQi qi) <> "(" <> argFrag <> ")"
 
     returnedColumns :: H.Snippet
     returnedColumns

src/PostgREST/Request/DbRequestBuilder.hs

@@ -18,7 +18,7 @@ resource.
 module PostgREST.Request.DbRequestBuilder
   ( readRequest
   , mutateRequest
-  , returningCols
+  , callRequest
   ) where
 
 import qualified Data.HashMap.Strict as M
@@ -33,6 +33,9 @@ import Data.Tree               (Tree (..))
 import PostgREST.DbStructure.Identifiers  (FieldName,
                                            QualifiedIdentifier (..),
                                            Schema, TableName)
+import PostgREST.DbStructure.Proc         (ProcDescription (..),
+                                           ProcParam (..),
+                                           procReturnsScalar)
 import PostgREST.DbStructure.Relationship (Cardinality (..),
                                            Junction (..),
                                            Relationship (..))
@@ -343,6 +346,23 @@ mutateRequest schema tName apiRequest pkCols readReq = mapLeft ApiRequestError $
     onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)
     body = pjRaw <$> iPayload apiRequest
 
+callRequest :: ProcDescription -> ApiRequest -> ReadRequest -> CallRequest
+callRequest proc apiReq readReq = FunctionCall {
+  funCQi = QualifiedIdentifier (pdSchema proc) (pdName proc)
+, funCParams = specifiedParams
+, funCArgs = pjRaw <$> iPayload apiReq
+, funCScalar = procReturnsScalar proc
+, funCMultipleCall = iPreferParameters apiReq == Just MultipleObjects
+, funCSingleParam = paramsAsSingleObject
+, funCReturning = returningCols readReq []
+}
+  where
+    paramsAsSingleObject = iPreferParameters apiReq == Just SingleObject
+    specifiedParams =
+      if paramsAsSingleObject
+        then pdParams proc
+        else filter (\x -> ppName x `S.member` iColumns apiReq) $ pdParams proc
+
 returningCols :: ReadRequest -> [FieldName] -> [FieldName]
 returningCols rr@(Node _ forest) pkCols
   -- if * is part of the select, we must not add pk or fk columns manually -

src/PostgREST/Request/Types.hs

@@ -6,6 +6,8 @@ module PostgREST.Request.Types
   , EmbedPath
   , Field
   , Filter(..)
+  , CallQuery(..)
+  , CallRequest
   , JoinCondition(..)
   , JsonOperand(..)
   , JsonOperation(..)
@@ -38,6 +40,7 @@ import qualified GHC.Show (show)
 
 import PostgREST.DbStructure.Identifiers  (FieldName,
                                            QualifiedIdentifier)
+import PostgREST.DbStructure.Proc         (ProcParam)
 import PostgREST.DbStructure.Relationship (Relationship)
 import PostgREST.RangeQuery               (NonnegRange)
 import PostgREST.Request.Preferences      (PreferResolution)
@@ -47,6 +50,7 @@ import Protolude
 
 type ReadRequest = Tree ReadNode
 type MutateRequest = MutateQuery
+type CallRequest = CallQuery
 
 type ReadNode =
   (ReadQuery, (NodeName, Maybe Relationship, Maybe Alias, Maybe EmbedHint, Depth))
@@ -121,6 +125,16 @@ data MutateQuery
       , returning :: [FieldName]
       }
 
+data CallQuery = FunctionCall
+  { funCQi           :: QualifiedIdentifier
+  , funCParams       :: [ProcParam]
+  , funCArgs         :: Maybe BL.ByteString
+  , funCScalar       :: Bool
+  , funCMultipleCall :: Bool
+  , funCSingleParam  :: Bool
+  , funCReturning    :: [FieldName]
+  }
+
 -- | The select value in `/tbl?select=alias:field::cast`
 type SelectItem = (Field, Maybe Cast, Maybe Alias, Maybe EmbedHint)
 

test/QueryCost.hs

@@ -15,11 +15,10 @@ import Protolude      hiding (get, toS)
 import Protolude.Conv (toS)
 
 import PostgREST.Query.QueryBuilder (requestToCallProcQuery)
-import PostgREST.Request.ApiRequest (PayloadJSON (..))
+import PostgREST.Request.Types      (CallQuery (..))
 
 import PostgREST.DbStructure.Identifiers
 import PostgREST.DbStructure.Proc
-import PostgREST.Request.Preferences
 
 import SpecHelper (getEnvVarWithDefault)
 
@@ -34,29 +33,30 @@ main = do
     context "call proc query" $ do
       it "should not exceed cost when calling setof composite proc" $ do
         cost <- exec pool $
-          requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [ProcParam "id" "int" True False]
+          requestToCallProcQuery (FunctionCall (QualifiedIdentifier "test" "get_projects_below") [ProcParam "id" "int" True False]
-          (Just $ RawJSON [str| {"id": 3} |]) False Nothing []
+          (Just [str| {"id": 3} |]) False False False [])
         liftIO $
           cost `shouldSatisfy` (< Just 40)
 
       it "should not exceed cost when calling setof composite proc with empty params" $ do
         cost <- exec pool $
-          requestToCallProcQuery (QualifiedIdentifier "test" "getallprojects") [] Nothing False Nothing []
+          requestToCallProcQuery (FunctionCall (QualifiedIdentifier "test" "getallprojects") [] Nothing False False False [])
         liftIO $
           cost `shouldSatisfy` (< Just 30)
 
       it "should not exceed cost when calling scalar proc" $ do
         cost <- exec pool $
-          requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [ProcParam "a" "int" True False, ProcParam "b" "int" True False]
+          requestToCallProcQuery (FunctionCall (QualifiedIdentifier "test" "add_them")
-          (Just $ RawJSON [str| {"a": 3, "b": 4} |]) True Nothing []
+          [ProcParam "a" "int" True False, ProcParam "b" "int" True False]
+          (Just [str| {"a": 3, "b": 4} |]) True False False [])
         liftIO $
           cost `shouldSatisfy` (< Just 10)
 
       context "params=multiple-objects" $ do
         it "should not exceed cost when calling setof composite proc" $ do
           cost <- exec pool $
-            requestToCallProcQuery (QualifiedIdentifier "test" "get_projects_below") [ProcParam "id" "int" True False]
+            requestToCallProcQuery (FunctionCall (QualifiedIdentifier "test" "get_projects_below") [ProcParam "id" "int" True False]
-            (Just $ RawJSON [str| [{"id": 1}, {"id": 4}] |]) False (Just MultipleObjects) []
+            (Just [str| [{"id": 1}, {"id": 4}] |]) False True False [])
           liftIO $ do
             -- lower bound needed for now to make sure that cost is not Nothing
             cost `shouldSatisfy` (> Just 2000)
@@ -64,8 +64,9 @@ main = do
 
         it "should not exceed cost when calling scalar proc" $ do
           cost <- exec pool $
-            requestToCallProcQuery (QualifiedIdentifier "test" "add_them") [ProcParam "a" "int" True False, ProcParam "b" "int" True False]
+            requestToCallProcQuery (FunctionCall (QualifiedIdentifier "test" "add_them")
-            (Just $ RawJSON [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]) True Nothing []
+            [ProcParam "a" "int" True False, ProcParam "b" "int" True False]
+            (Just [str| [{"a": 3, "b": 4}, {"a": 1, "b": 2}, {"a": 8, "b": 7}] |]) True False False [])
           liftIO $
             cost `shouldSatisfy` (< Just 10)