Allow GET on RPC (#946)

2017-09-17 11:16:46 -05:00
parent 32117ba477
commit cf19ad0369
12 changed files with 375 additions and 250 deletions
@@ -19,7 +19,7 @@ import qualified Data.ByteString.Internal  as BS (c2w)
 import qualified Data.ByteString.Lazy      as BL
 import qualified Data.Csv                  as CSV
 import qualified Data.List                 as L
-import           Data.List                 (lookup, last)
+import           Data.List                 (lookup, last, partition)
 import qualified Data.HashMap.Strict       as M
 import qualified Data.Set                  as S
 import           Data.Maybe                (fromJust)
@@ -38,7 +38,8 @@ import           PostgREST.Types           ( QualifiedIdentifier (..)
                                           , PayloadJSON(..)
                                           , ContentType(..)
                                           , ApiRequestError(..)
-                                           , toMime)
+                                           , toMime
+                                           , operators)
 import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)
 import qualified Data.CaseInsensitive      as CI
 import           Web.Cookie                (parseCookiesText)
@@ -48,7 +49,7 @@ type RequestBody = BL.ByteString
 -- | Types of things a user wants to do to tables/views/procs
 data Action = ActionCreate | ActionRead
            | ActionUpdate | ActionDelete
-            | ActionInfo   | ActionInvoke
+            | ActionInfo   | ActionInvoke{isReadOnly :: Bool}
            | ActionInspect
            deriving Eq
 -- | The target db object of a user action
@@ -100,12 +101,14 @@ data ApiRequest = ApiRequest {
  , iHeaders :: [(Text, Text)]
  -- | Request Cookies
  , iCookies :: [(Text, Text)]
+  -- | Rpc query params e.g. /rpc/name?param1=val1, similar to filter but with no operator(eq, lt..)
+  , iRpcQParams :: [(Text, Text)]
  }

 -- | Examines HTTP request and translates it into user intent.
 userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
 userApiRequest schema req reqBody
-  | isTargetingProc && method /= "POST" = Left ActionInappropriate
+  | isTargetingProc && method `notElem` ["GET", "POST"] = Left ActionInappropriate
  | topLevelRange == emptyRange = Left InvalidRange
  | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) undefined payload
  | otherwise = Right ApiRequest {
@@ -118,7 +121,8 @@ userApiRequest schema req reqBody
      , iPreferRepresentation = representation
      , iPreferSingleObjectParameter = singleObject
      , iPreferCount = hasPrefer "count=exact"
-      , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
+      , iFilters = filters
+      , iRpcQParams = rpcQParams
      , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
      , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
@@ -132,6 +136,13 @@ userApiRequest schema req reqBody
      , iCookies = fromMaybe [] $ parseCookiesText <$> lookupHeader "Cookie"
      }
 where
+  (filters, rpcQParams) =
+    case action of
+      ActionInvoke{isReadOnly=True} -> partition (liftM2 (||) (isEmbedPath . fst) (hasOperator . snd)) flts
+      _ -> (flts, [])
+  flts = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset", "and", "or"] k) ]
+  hasOperator val = foldr ((||) . flip T.isPrefixOf val) False $ (<> ".") <$> M.keys operators
+  isEmbedPath = T.isInfixOf "."
  isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
  payload =
    case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of
@@ -150,17 +161,19 @@ userApiRequest schema req reqBody
      ct ->
        Left $ toS $ "Content-Type not acceptable: " <> toMime ct
  topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges
-  action = case method of
-            "GET"     -> if target == TargetRoot
-                          then ActionInspect
-                          else ActionRead
-            "POST"    -> if isTargetingProc
-                          then ActionInvoke
-                          else ActionCreate
-            "PATCH"   -> ActionUpdate
-            "DELETE"  -> ActionDelete
-            "OPTIONS" -> ActionInfo
-            _         -> ActionInspect
+  action =
+    case method of
+      "GET"      | target == TargetRoot -> ActionInspect
+                 | isTargetingProc -> ActionInvoke{isReadOnly=True}
+                 | otherwise -> ActionRead
+
+      "POST"    -> if isTargetingProc
+                    then ActionInvoke{isReadOnly=False}
+                    else ActionCreate
+      "PATCH"   -> ActionUpdate
+      "DELETE"  -> ActionDelete
+      "OPTIONS" -> ActionInfo
+      _         -> ActionInspect
  target = case path of
              []            -> TargetRoot
              [table]       -> TargetIdent
@@ -168,10 +181,10 @@ userApiRequest schema req reqBody
              ["rpc", proc] -> TargetProc
                              $ QualifiedIdentifier schema proc
              other         -> TargetUnknown other
-  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke]
-  relevantPayload = if shouldParsePayload
-                      then rightToMaybe payload
-                      else Nothing
+  shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}]
+  relevantPayload | action == ActionInvoke{isReadOnly=True} = Nothing
+                  | shouldParsePayload = rightToMaybe payload
+                  | otherwise = Nothing
  path            = pathInfo req
  method          = requestMethod req
  hdrs            = requestHeaders req
@@ -6,6 +6,7 @@ module PostgREST.App (
 ) where

 import           Control.Applicative
+import           Data.Aeson                (toJSON)
 import qualified Data.ByteString.Char8     as BS
 import           Data.Maybe
 import           Data.IORef                (IORef, readIORef)
@@ -37,6 +38,7 @@ import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.DbStructure
 import           PostgREST.DbRequestBuilder( readRequest
                                           , mutateRequest
+                                           , readRpcRequest
                                           , fieldNames
                                           )
 import           PostgREST.Error           ( simpleError, pgError
@@ -94,7 +96,7 @@ transactionMode structure target action =
    ActionRead -> HT.Read
    ActionInfo -> HT.Read
    ActionInspect -> HT.Read
-    ActionInvoke ->
+    ActionInvoke{isReadOnly=False} ->
      let proc =
            case target of
              (TargetProc qi) -> M.lookup (qiName qi) $
@@ -104,6 +106,7 @@ transactionMode structure target action =
      if v == Stable || v == Immutable
         then HT.Read
         else HT.Write
+    ActionInvoke{isReadOnly=True} -> HT.Read
    _ -> HT.Write

 app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
@@ -227,7 +230,7 @@ app dbStructure conf apiRequest =
              let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
              return $ responseLBS status200 [allOrigins, acceptH] ""

-        (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->
+        (ActionInvoke _isReadOnly, TargetProc qi, payload) ->
          let proc = M.lookup (qiName qi) allProcs
              returnsScalar = case proc of
                Just ProcDescription{pdReturnType = (Single (Scalar _))} -> True
@@ -235,18 +238,20 @@ app dbStructure conf apiRequest =
              rpcBinaryField = if returnsScalar
                                 then Right Nothing
                                 else binaryField contentType =<< fldNames
-              partsField = (,) <$> readSqlParts <*> rpcBinaryField in
-          case partsField of
+              parts = (,,) <$> readSqlParts <*> rpcBinaryField <*> rpcQParams in
+          case parts of
            Left errorResponse -> return errorResponse
-            Right ((q, cq), bField) -> do
-              let p = V.head payload
+            Right ((q, cq), bField, params) -> do
+              let prms = case payload of
+                          Just (PayloadJSON pld) -> V.head pld
+                          Nothing -> M.fromList $ second toJSON <$> params -- toJSON is just for reusing the callProc function
                  singular = contentType == CTSingularJSON
                  paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
              row <- H.query () $
-                callProc qi p returnsScalar q cq topLevelRange shouldCount
+                callProc qi prms returnsScalar q cq topLevelRange shouldCount
                         singular paramsAsSingleObject
                         (contentType == CTTextCSV)
-                         (contentType == CTOctetStream) bField
+                         (contentType == CTOctetStream) _isReadOnly bField
              let (tableTotal, queryTotal, body) =
                    fromMaybe (Just 0, 0, "[]") row
                  (status, contentRange) = rangeHeader queryTotal tableTotal
@@ -298,6 +303,7 @@ app dbStructure conf apiRequest =
      fldNames = fieldNames <$> readReq
      readDbRequest = DbRead <$> readReq
      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< fldNames)
+      rpcQParams = readRpcRequest apiRequest
      selectQuery = requestToQuery schema False <$> readDbRequest
      mutateQuery = requestToQuery schema False <$> mutateDbRequest
      countQuery = requestToCountQuery schema <$> readDbRequest
@@ -313,7 +319,7 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
        ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
        ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
        ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
+        ActionInvoke _ ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
        ActionInspect -> [CTOpenAPI, CTApplicationJSON]
        ActionInfo ->    [CTTextCSV]
    serves sProduces cAccepts =
@@ -3,6 +3,7 @@
 module PostgREST.DbRequestBuilder (
  readRequest
 , mutateRequest
+, readRpcRequest
 , fieldNames
 ) where

@@ -72,10 +73,10 @@ readRequest maxRows allRels allProcs apiRequest  =

    relations :: [Relation]
    relations = case action of
-      ActionCreate -> fakeSourceRelations ++ allRels
-      ActionUpdate -> fakeSourceRelations ++ allRels
-      ActionDelete -> fakeSourceRelations ++ allRels
-      ActionInvoke -> fakeSourceRelations ++ allRels
+      ActionCreate   -> fakeSourceRelations ++ allRels
+      ActionUpdate   -> fakeSourceRelations ++ allRels
+      ActionDelete   -> fakeSourceRelations ++ allRels
+      ActionInvoke _ -> fakeSourceRelations ++ allRels
      _       -> allRels
      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation

@@ -222,9 +223,11 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
    logicForest = mapM pRequestLogicTree logFrst
    action = iAction apiRequest
    -- there can be no filters on the root table when we are doing insert/update/delete
-    (flts, logFrst)
-      | action == ActionRead || action == ActionInvoke = (iFilters apiRequest, iLogic apiRequest)
-      | otherwise = join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
+    (flts, logFrst) =
+      case action of
+        ActionInvoke _ -> (iFilters apiRequest, iLogic apiRequest)
+        ActionRead     -> (iFilters apiRequest, iLogic apiRequest)
+        _              -> join (***) (filter (( "." `isInfixOf` ) . fst)) (iFilters apiRequest, iLogic apiRequest)
    orders :: Either ApiRequestError [(EmbedPath, [OrderTerm])]
    orders = mapM pRequestOrder $ iOrder apiRequest
    ranges :: Either ApiRequestError [(EmbedPath, NonnegRange)]
@@ -310,6 +313,11 @@ mutateRequest apiRequest fldNames = mapLeft apiRequestError $
    (mutateFilters, logicFilters) = join (***) onlyRoot (iFilters apiRequest, iLogic apiRequest)
    onlyRoot = filter (not . ( "." `isInfixOf` ) . fst)

+readRpcRequest :: ApiRequest -> Either Response [RpcQParam]
+readRpcRequest apiRequest = mapLeft apiRequestError rpcQParams
+  where
+    rpcQParams = mapM pRequestRpcQParam $ iRpcQParams apiRequest
+
 fieldNames :: ReadRequest -> [FieldName]
 fieldNames (Node (sel, _) forest) =
  map (fst . view _1) (select sel) ++ map colName fks
@@ -44,9 +44,15 @@ pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
    path = parse pLogicPath ("failed to parser logic path (" ++ toS k ++ ")") $ toS k
    embedPath = fst <$> path
    op = snd <$> path
-    -- Concat op and v to make pLogicTree argument regular, in the form of "op(.,.)"
+    -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
    logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)

+pRequestRpcQParam :: (Text, Text) -> Either ApiRequestError RpcQParam
+pRequestRpcQParam (k, v) = mapError $ (,) <$> name <*> val
+  where
+    name = parse pFieldName ("failed to parse rpc arg name (" ++ toS k ++ ")") $ toS k
+    val = toS <$> parse (many anyChar) ("failed to parse rpc arg value (" ++ toS v ++ ")") v
+
 ws :: Parser Text
 ws = toS <$> many (oneOf " \t")

@@ -144,8 +144,8 @@ createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys

 type ProcResults = (Maybe Int64, Int64, ByteString)
 callProc :: QualifiedIdentifier -> JSON.Object -> Bool -> SqlQuery -> SqlQuery -> NonnegRange ->
-  Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> H.Query () (Maybe ProcResults)
-callProc qi params returnsScalar selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv asBinary binaryField =
+  Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> H.Query () (Maybe ProcResults)
+callProc qi params returnsScalar selectQuery countQuery _ countTotal isSingle paramsAsJson asCsv asBinary isReadOnly binaryField =
  unicodeStatement sql HE.unit decodeProc True
  where
    sql =
@@ -165,7 +165,7 @@ callProc qi params returnsScalar selectQuery countQuery _ countTotal isSingle pa
       FROM ({selectQuery}) _postgrest_t;|]

    countResultF = if countTotal then "( "<> countQuery <> ")" else "null::bigint" :: Text
-    _args = if paramsAsJson
+    _args = if paramsAsJson && not isReadOnly
                then insertableValueWithType "json" $ JSON.Object params
                else intercalate "," $ map _assignment (HM.toList params)
    _procName = qiName qi
@@ -208,6 +208,9 @@ type Alias = Text
 type Cast = Text
 type NodeName = Text

+-- Rpc query param, only used for GET rpcs
+type RpcQParam = (Text, Text)
+
 {-|
  This type will hold information about which particular 'Relation' between two tables to choose when there are multiple ones.
  Specifically, it will contain the name of the foreign key or the join table in many to many relations.