Fix alias in select for mutate queries and small refactor (#779)

CHANGELOG.md

@@ -28,6 +28,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 - Fatal error on postgres unsupported version, format supported version in error message - @steve-chavez
 - Prevent database memory cosumption by prepared statements caches - @ruslantalpa
 - Use specific columns in the RETURNING section - @ruslantalpa
+- Fix columns alias for RETURNING - @steve-chavez
 
 ### Changed
 - Replace `Prefer: plurality=singular` with `Accept: application/vnd.pgrst.object` - @begriffs

src/PostgREST/App.hs

@@ -7,6 +7,8 @@ module PostgREST.App (
 ) where
 
 import           Control.Applicative
+import           Control.Lens.Getter       (view)
+import           Control.Lens.Tuple        (_1)
 import qualified Data.ByteString.Char8     as BS
 import           Data.IORef                (IORef, readIORef)
 import           Data.List                 (delete, lookup)
@@ -21,7 +23,6 @@ import qualified Hasql.Transaction          as HT
 import qualified Hasql.Transaction.Sessions as HT
 
 import           Text.Parsec.Error
-import           Text.ParserCombinators.Parsec (parse)
 
 import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
@@ -59,7 +60,6 @@ import           PostgREST.QueryBuilder ( callProc
                                         , createReadStatement
                                         , createWriteStatement
                                         , ResultsWithCount
-                                        , returningF
                                         )
 import           PostgREST.Types
 import           PostgREST.OpenAPI
@@ -268,11 +268,11 @@ app dbStructure conf apiRequest =
         in (status, contentRange)
 
       mapSnd f (a, b) = (a, f b)
-      readDbRequest = DbRead <$> readRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
-      mutateDbRequest = DbMutate <$> mutateRequest apiRequest
-      returningSql = returningF (iTarget apiRequest) (iPreferRepresentation apiRequest) <$> readDbRequest
-      selectQuery = requestToQuery schema False "" <$> readDbRequest
-      mutateQuery = requestToQuery schema False <$> returningSql <*> mutateDbRequest
+      readReq = readRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
+      readDbRequest = DbRead <$> readReq
+      mutateDbRequest = DbMutate <$> (mutateRequest apiRequest =<< readReq)
+      selectQuery = requestToQuery schema False <$> readDbRequest
+      mutateQuery = requestToQuery schema False <$> mutateDbRequest
       countQuery = requestToCountQuery schema <$> readDbRequest
       readSqlParts = (,) <$> selectQuery <*> countQuery
       mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
@@ -388,7 +388,7 @@ readRequest maxRows allRels allProcs apiRequest  =
 
     parseReadRequest :: Either ParseError ReadRequest
     parseReadRequest = addFiltersOrdersRanges apiRequest <*>
-      parse (pRequestSelect rootName) ("failed to parse select parameter <<" <> toS selStr <> ">>") (toS selStr)
+      pRequestSelect rootName selStr
       where
         selStr = iSelect apiRequest
         rootName = if action == ActionRead
@@ -404,12 +404,12 @@ readRequest maxRows allRels allProcs apiRequest  =
       _       -> allRels
       where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
 
-mutateRequest :: ApiRequest -> Either Response MutateRequest
-mutateRequest apiRequest = mapLeft (errResponse status400) $
+mutateRequest :: ApiRequest -> ReadRequest -> Either Response MutateRequest
+mutateRequest apiRequest readReq = mapLeft (errResponse status400) $
   case action of
-    ActionCreate -> Insert rootTableName <$> pure payload
-    ActionUpdate -> Update rootTableName <$> pure payload <*> filters
-    ActionDelete -> Delete rootTableName <$> filters
+    ActionCreate -> Right $ Insert rootTableName payload returnings
+    ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings
+    ActionDelete -> Delete rootTableName <$> filters <*> pure returnings
     _        -> Left "Unsupported HTTP verb"
   where
     action = iAction apiRequest
@@ -419,6 +419,15 @@ mutateRequest apiRequest = mapLeft (errResponse status400) $
       case target of
         (TargetIdent (QualifiedIdentifier _ t) ) -> t
         _ -> undefined
+    fieldNames :: ReadRequest -> PreferRepresentation -> [FieldName]
+    fieldNames _ None = []
+    fieldNames (Node (sel, _) forest) _ =
+      map (fst . view _1) (select sel) ++ map colName fks
+      where
+        fks = concatMap (fromMaybe [] . f) forest
+        f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols
+        f _ = Nothing
+    returnings = fieldNames readReq (iPreferRepresentation apiRequest) 
     filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
       where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
 

src/PostgREST/Parsers.hs

@@ -10,20 +10,9 @@ import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
 import           PostgREST.RangeQuery      (NonnegRange,allRange)
 
-pRequestSelect :: Text -> Parser ReadRequest
-pRequestSelect rootNodeName = do
-  fieldTree <- pFieldForest
-  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree
-  where
-    readQuery = Select [] [rootNodeName] [] Nothing allRange
-    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
-    treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =
-      case fldForest of
-        [] -> Node (q {select=fld:select q}, i) rForest
-        _  -> Node (q, i) newForest
-          where
-            newForest =
-              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest
+pRequestSelect :: Text -> Text -> Either ParseError ReadRequest
+pRequestSelect rootName selStr = 
+  parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
 
 pRequestFilter :: (Text, Text) -> Either ParseError (Path, Filter)
 pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
@@ -54,6 +43,21 @@ ws = toS <$> many (oneOf " \t")
 lexeme :: Parser a -> Parser a
 lexeme p = ws *> p <* ws
 
+pReadRequest :: Text -> Parser ReadRequest
+pReadRequest rootNodeName = do
+  fieldTree <- pFieldForest
+  return $ foldr treeEntry (Node (readQuery, (rootNodeName, Nothing, Nothing)) []) fieldTree
+  where
+    readQuery = Select [] [rootNodeName] [] Nothing allRange
+    treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
+    treeEntry (Node fld@((fn, _),_,alias) fldForest) (Node (q, i) rForest) =
+      case fldForest of
+        [] -> Node (q {select=fld:select q}, i) rForest
+        _  -> Node (q, i) newForest
+          where
+            newForest =
+              foldr treeEntry (Node (Select [] [fn] [] Nothing allRange, (fn, Nothing, alias)) []) fldForest:rForest
+
 pTreePath :: Parser (Path,Field)
 pTreePath = do
   p <- pFieldName `sepBy1` pDelimiter

src/PostgREST/QueryBuilder.hs

@@ -23,7 +23,6 @@ module PostgREST.QueryBuilder (
   , pgFmtLit
   , requestToQuery
   , requestToCountQuery
-  , returningF
   , sourceCTEName
   , unquoted
   , ResultsWithCount
@@ -53,7 +52,7 @@ import           Data.Scientific         ( FPFormat (..)
                                          , isInteger
                                          )
 import           Protolude hiding        (from, intercalate, ord, cast)
-import           PostgREST.ApiRequest    (PreferRepresentation (..), Target (..))
+import           PostgREST.ApiRequest    (PreferRepresentation (..))
 import           Unsafe                  (unsafeHead)
 
 {-| The generic query result format used by API responses. The location header
@@ -312,8 +311,8 @@ requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _
    fn Filter{value=VForeignKey _ _} = False
    localConditions = filter fn conditions
 
-requestToQuery :: Schema -> Bool -> SqlFragment -> DbRequest -> SqlQuery
-requestToQuery schema isParent _ (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =
+requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery
+requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =
   query
   where
     -- TODO! the following helper functions are just to remove the "schema" part when the table is "source" which is the name
@@ -350,7 +349,7 @@ requestToQuery schema isParent _ (DbRead (Node (Select colSelects tbls condition
            <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
            <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
-           where subquery = requestToQuery schema False "" (DbRead (Node n forst))
+           where subquery = requestToQuery schema False (DbRead (Node n forst))
     getQueryParts (Node n@(_, (name, Just r@Relation{relType=Parent,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (joi:j,sel:s)
       where
         node_name = fromMaybe name alias
@@ -360,20 +359,20 @@ requestToQuery schema isParent _ (DbRead (Node (Select colSelects tbls condition
         sel = "row_to_json(" <> pgFmtIdent local_table_name <> ".*) AS " <> pgFmtIdent node_name
         joi = " LEFT OUTER JOIN ( " <> subquery <> " ) AS " <> pgFmtIdent local_table_name  <>
               " ON " <> intercalate " AND " ( map (pgFmtCondition qi . replaceTableName local_table_name) (getJoinConditions r) )
-          where subquery = requestToQuery schema True "" (DbRead (Node n forst))
+          where subquery = requestToQuery schema True (DbRead (Node n forst))
     getQueryParts (Node n@(_, (name, Just Relation{relType=Many,relTable=Table{tableName=table}}, alias)) forst) (j,s) = (j,sel:s)
       where
         sel = "COALESCE (("
            <> "SELECT array_to_json(array_agg(row_to_json("<>pgFmtIdent table<>"))) "
            <> "FROM (" <> subquery <> ") " <> pgFmtIdent table
            <> "), '[]') AS " <> pgFmtIdent (fromMaybe name alias)
-           where subquery = requestToQuery schema False "" (DbRead (Node n forst))
+           where subquery = requestToQuery schema False (DbRead (Node n forst))
     --the following is just to remove the warning
     --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
     --posible relations are Child Parent Many
     getQueryParts _ _ = undefined
-requestToQuery schema _ returningSql (DbMutate (Insert mainTbl (PayloadJSON rows))) =
-  insInto <> vals <> returningSql
+requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows) returnings)) =
+  insInto <> vals <> ret
   where qi = QualifiedIdentifier schema mainTbl
         cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
         colsString = intercalate ", " cols
@@ -384,7 +383,10 @@ requestToQuery schema _ returningSql (DbMutate (Insert mainTbl (PayloadJSON rows
           if T.null colsString
             then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"]
             else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]
-requestToQuery schema _ returningSql (DbMutate (Update mainTbl (PayloadJSON rows) conditions)) =
+        ret = if null returnings 
+                  then ""
+                  else unwords [" RETURNING ", intercalate ", " (map (pgFmtColumn qi) returnings)]
+requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions returnings)) =
   case rows V.!? 0 of
     Just obj ->
       let assignments = map
@@ -393,32 +395,21 @@ requestToQuery schema _ returningSql (DbMutate (Update mainTbl (PayloadJSON rows
         "UPDATE ", fromQi qi,
         " SET " <> intercalate "," assignments <> " ",
         ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-        returningSql
+        ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings
         ]
     Nothing -> undefined
   where
     qi = QualifiedIdentifier schema mainTbl
-requestToQuery schema _ returningSql (DbMutate (Delete mainTbl conditions)) =
+requestToQuery schema _ (DbMutate (Delete mainTbl conditions returnings)) =
   query
   where
     qi = QualifiedIdentifier schema mainTbl
     query = unwords [
       "DELETE FROM ", fromQi qi,
       ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-      returningSql
+      ("RETURNING " <> intercalate ", " (map (pgFmtColumn qi) returnings)) `emptyOnNull` returnings
       ]
 
-returningF :: Target -> PreferRepresentation -> DbRequest -> SqlFragment
-returningF _ None _ = ""
-returningF (TargetIdent qi) _ (DbRead (Node (Select colSelects _ _ _ _, (_, _, _)) forest)) =
-  " RETURNING " <>
-  intercalate ", " ( map (pgFmtSelectItem qi) colSelects ++ map (pgFmtColumn qi . colName) fks)
-  where
-    fks = concatMap (fromMaybe [] . f) forest
-    f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols
-    f _ = Nothing
-returningF _ _ _ = ""
-
 sourceCTEName :: SqlFragment
 sourceCTEName = "pg_source"
 

src/PostgREST/Types.hs

@@ -125,9 +125,9 @@ type NodeName = Text
 type SelectItem = (Field, Maybe Cast, Maybe Alias)
 type Path = [Text]
 data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq)
-data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON }
-                 | Delete { in_::TableName, where_::[Filter] }
-                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter] } deriving (Show, Eq)
+data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON, returning::[FieldName] }
+                 | Delete { in_::TableName, where_::[Filter], returning::[FieldName] }
+                 | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter], returning::[FieldName] } deriving (Show, Eq)
 data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
 type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
 type ReadRequest = Tree ReadNode

test/Feature/DeleteSpec.hs

@@ -35,6 +35,9 @@ spec =
           , matchStatus  = 200
           , matchHeaders = ["Content-Range" <:> "*/*"]
           }
+      it "can rename and cast the selected columns" $
+        request methodDelete "/complex_items?id=eq.3&select=ciId:id::text,ciName:name" [("Prefer", "return=representation")] ""
+          `shouldRespondWith` [str|[{"ciId":"3","ciName":"Three"}]|]
       it "can embed (parent) entities" $
         request methodDelete "/tasks?id=eq.8&select=id,name,project{id}" [("Prefer", "return=representation")] ""
           `shouldRespondWith` ResponseMatcher {

test/Feature/InsertSpec.hs

@@ -49,6 +49,7 @@ spec = do
           , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]
           }
 
+    context "requesting full representation" $ do
       it "includes related data after insert" $
         request methodPost "/projects?select=id,name,clients{id,name}"
                 [("Prefer", "return=representation"), ("Prefer", "count=exact")]
@@ -60,6 +61,17 @@ spec = do
                            , "Content-Range" <:> "*/1" ]
           }
 
+      it "can rename and cast the selected columns" $
+        request methodPost "/projects?select=pId:id::text,pName:name,cId:client_id::text"
+                [("Prefer", "return=representation")] 
+          [str|{"id":7,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"pId":"7","pName":"New Project","cId":"2"}]|]
+          , matchStatus  = 201
+          , matchHeaders = [ "Content-Type" <:> "application/json; charset=utf-8"
+                           , "Location" <:> "/projects?id=eq.7"
+                           , "Content-Range" <:> "*/*" ]
+          }
+
     context "from an html form" $
       it "accepts disparate json types" $ do
         p <- request methodPost "/menagerie"
@@ -277,6 +289,17 @@ spec = do
                             "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
           }
 
+      it "only returns the requested column header with its associated data" $
+        request methodPost "/projects?select=id"
+                     [("Content-Type", "text/csv"), ("Accept", "text/csv"), ("Prefer", "return=representation")]
+                     "id,name,client_id\n8,Xenix,1\n9,Windows NT,1"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "id\n8\n9"
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "text/csv; charset=utf-8",
+                            "Content-Range" <:> "*/*"]
+          }
+
     context "with wrong number of columns" $
       it "fails for too few" $ do
         p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"