Allow GET on RPC (PostgREST#946)

monacoremo · Sep 17, 2017 · 6ea9a28 · 6ea9a28
1 parent d9ea354
commit 6ea9a28
Show file tree

Hide file tree

Showing 12 changed files with 375 additions and 250 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -8,6 +8,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 ### Added
 
 - #887, #601, Allow specifying dictionary and plain/phrase tsquery in full text search - @steve-chavez
+- #328, Allow doing GET on rpc - @steve-chavez
 
 ### Fixed
 

diff --git a/postgrest.cabal b/postgrest.cabal
@@ -126,6 +126,7 @@ Test-Suite spec
                      , Feature.StructureSpec
                      , Feature.UnicodeSpec
                      , Feature.AndOrParamsSpec
+                     , Feature.RpcSpec
                      , SpecHelper
                      , TestTypes
   Build-Depends:       aeson

diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs
@@ -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,28 +161,30 @@ 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
                               $ QualifiedIdentifier schema table
               ["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

diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs
@@ -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,26 +230,28 @@ 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
                 _ -> False
               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 =

diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs
@@ -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

diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs
@@ -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")
 

diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs
@@ -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

diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs
@@ -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.