shape the response after inserting

src/PostgREST/App.hs

@@ -24,7 +24,7 @@ import qualified Data.Csv                  as CSV
 import           Data.Functor.Identity
 import qualified Data.HashMap.Strict       as M
 import           Data.List                 (find, sortBy, delete, transpose)
-import           Data.Maybe                (fromMaybe, fromJust, isJust, isNothing)
+import           Data.Maybe                (fromMaybe, fromJust, isJust, isNothing, mapMaybe)
 import           Data.Ord                  (comparing)
 import           Data.Ranged.Ranges        (emptyRange)
 import qualified Data.Set                  as S
@@ -61,6 +61,7 @@ import           PostgREST.Types
 import           PostgREST.Auth (tokenJWT)
 
 import           Prelude
+import           Debug.Trace
 
 app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
 app dbstructure conf reqBody req =
@@ -76,12 +77,12 @@ app dbstructure conf reqBody req =
             let q = B.Stmt
                     (
                       wrapQuery qs [
-                        (if hasPrefer "count=none" then countNoneF else countAllF),
+                        if hasPrefer "count=none" then countNoneF else countAllF,
                         countF,
                         case contentType of
                           "text/csv" -> asCsvF -- TODO check when in csv mode if the header is correct when requesting nested data
                           _     -> asJsonF
-                      ] range
+                      ] selectStarF range
                     )
                     V.empty True
             row <- H.maybeEx q
@@ -104,32 +105,32 @@ app dbstructure conf reqBody req =
 
         where
             frm = fromMaybe 0 $ rangeOffset <$> range
-            apiRequest = parseGetRequest table req
+            -- apiRequest = parseGetRequest table req
-                     >>= first formatRelationError . addRelations schema allRels Nothing
+            --          >>= first formatRelationError . addRelations schema allRels Nothing
-                     >>= addJoinConditions schema allCols
+            --          >>= addJoinConditions schema allCols
+            apiRequest = parseGetRequest table req >>= augumentRequestWithJoin schema allRels
             query = requestToQuery schema <$> apiRequest
 
     ([table], "POST") -> do
       let echoRequested = hasPrefer "return=representation"
-      case insertQuery of
+      case queries of
         Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
-        Right qs -> do
+        Right (qi, qs) -> do
           let isSingle = either (const False) id returnSingle
               pKeys = map pkName $ filter (filterPk schema table) allPrKeys
               q = B.Stmt
                     (
-                      wrapQuery qs [
+                      wrapQuery qi [
                         if isSingle then locationF pKeys else "null",
                         "null", -- countF,
-                        (
                         if echoRequested
                         then
                           case contentType of
                              "text/csv" -> asCsvF
                              _     -> if isSingle then asJsonSingleF else asJsonF
                         else "null"
-                        )
+
-                      ] Nothing
+                      ] qs Nothing
                     )
                     V.empty True
 
@@ -145,9 +146,18 @@ app dbstructure conf reqBody req =
             $ if echoRequested then body else ""
       where
         res = parsePostRequest table req reqBody
-        apiRequest = snd <$> res
+        ins = fst <$> res
-        returnSingle = fst <$> res
+        insertApiRequest = snd <$> ins
-        insertQuery = requestToQuery schema <$> apiRequest
+        returnSingle = fst <$> ins
+        insertQuery = requestToQuery schema <$> insertApiRequest
+        selectApiRequest = (snd <$> res) >>= augumentRequestWithJoin schema (fakeSourceRelations ++ allRels)
+        selectQuery = requestToQuery schema <$> selectApiRequest
+        queries = (,) <$> insertQuery <*> selectQuery
+        fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
+        --changeRootNodeToSource :: Text -> ApiRequest -> ApiRequest
+        --changeRootNodeToSource rootTableName (q, (rootTableName, r)) =
+
+        --returnSelect = selectStarF
 
     ([table], "PUT") ->
       handleJsonObj reqBody $ \obj -> do
@@ -350,11 +360,12 @@ formatParserError e = cs $ encode $ object [
      details = strip $ replace "\n" " " $ cs
        $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 
-parsePostRequest :: NodeName -> Request -> BL.ByteString -> Either Text (Bool, ApiRequest)
+-- quite ugly return type
+parsePostRequest :: NodeName -> Request -> BL.ByteString -> Either Text ((Bool, ApiRequest), ApiRequest)
 parsePostRequest rootTableName httpRequest reqBody =
-  (,) <$> returnSingle <*> node
+  (,) <$> ((,) <$> returnSingle <*> insertApiRequest) <*> returnApiRequest
   where
-    node = Node <$> apiNode <*> pure []
+    insertApiRequest = Node <$> apiNode <*> pure []
     apiNode = (,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)
     flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsed)
     vals = snd <$> parsed
@@ -366,6 +377,8 @@ parsePostRequest rootTableName httpRequest reqBody =
     lookupHeader  = flip lookup hdrs
     --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
     isCsv = lookupHeader "Content-Type" == Just csvMT
+    qParams = queryParams httpRequest
+    returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) (whereFilters qParams) (orderStr qParams)
 
 
 parseRequestBody :: Bool -> BL.ByteString -> Either Text ([Text],[[Value]])
@@ -426,17 +439,36 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
 
 parseGetRequest :: NodeName -> Request -> Either Text ApiRequest
 parseGetRequest rootTableName httpRequest =
+  buildSelectApiRequest rootTableName (selectStr qParams) (whereFilters qParams) (orderStr qParams)
+  where
+    qParams = queryParams httpRequest
+
+augumentRequestWithJoin :: Text ->  [Relation] ->  ApiRequest -> Either Text ApiRequest
+augumentRequestWithJoin schema allRels request = return request
+         >>= first formatRelationError . addRelations schema allRels Nothing
+         >>= addJoinConditions schema
+
+-- we use strings here because most of this data will be sent to parsers (which need strings for now)
+queryParams :: Request -> [(String, Maybe String)]
+queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
+
+selectStr :: [(String, Maybe String)] -> String
+selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
+
+whereFilters :: [(String, Maybe String)] -> [(String, String)]
+whereFilters qParams = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]
+
+orderStr :: [(String, Maybe String)] -> Maybe String
+orderStr qParams = join $ lookup "order" qParams
+
+buildSelectApiRequest :: Text -> String -> [(String, String)] -> Maybe String -> Either Text ApiRequest
+buildSelectApiRequest rootTableName sel wher orderS =
   first formatParserError $ foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
   where
-    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
+    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++sel++">>") $ sel
     addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
-    flts = mapM pRequestFilter whereFilters
+    flts = mapM pRequestFilter wher
-    --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
+    ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
-    qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
-    orderStr = join $ lookup "order" qString
-    ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr
-    selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to *
-    whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ]
 
 addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
 addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest
@@ -453,6 +485,12 @@ addFilter (path, flt) (Node rn forest) =
         Just node -> (Just node, delete node forest)
       where maybeNode = find ((name==).fst.snd.rootLabel) forst
 
+toSourceRelation :: Text -> Relation -> Maybe Relation
+toSourceRelation mt r@(Relation _ t _ ft _ _ rt _ _)
+  | mt == t = Just $ r {relTable=sourceSubqueryName}
+  | mt == ft = Just $ r {relFTable=sourceSubqueryName}
+  | Just mt == rt = Just $ r {relLTable=Just sourceSubqueryName}
+  | otherwise = Nothing
 
 data TableOptions = TableOptions {
   tblOptcolumns :: [Column]

src/PostgREST/Main.hs

@@ -2,6 +2,7 @@ module Main where
 
 
 import           PostgREST.App
+-- import PostgREST.QueryBuilder
 import           PostgREST.Config                     (AppConfig (..),
                                                        minimumPgVersion,
                                                        prettyVersion,
@@ -26,7 +27,7 @@ import           Network.Wai.Middleware.RequestLogger (logStdout)
 import           System.IO                            (BufferMode (..),
                                                        hSetBuffering, stderr,
                                                        stdin, stdout)
-
+-- import Data.Maybe (mapMaybe)
 
 isServerVersionSupported :: H.Session P.Postgres IO Bool
 isServerVersionSupported = do
@@ -86,8 +87,10 @@ main = do
     keys <- allPrimaryKeys
     return (tabs, rels, cols, keys)
 
+
   dbstructure <- either hasqlError
     (\(tabs, rels, cols, keys) ->
+
       return DbStructure {
           tables=tabs
         , columns=cols
@@ -96,6 +99,11 @@ main = do
         }
     ) metadata
 
+  -- let allRels = relations dbstructure
+  --     fakeRels = mapMaybe (toSourceRelation "projects") allRels
+  --
+  -- print $ findRelation (fakeRels ++ allRels) "test" "pg_source" "clients"
+
   runSettings appSettings $ middle $ \ req respond -> do
     body <- strictRequestBody req
     resOrError <- liftIO $ H.session pool $ H.tx txSettings $

src/PostgREST/PgQuery.hs

@@ -36,6 +36,7 @@ module PostgREST.PgQuery (
 , whereT
 
 -- query fragments
+, sourceSubqueryName
 , orderF
 , countNoneF
 , countAllF
@@ -44,6 +45,7 @@ module PostgREST.PgQuery (
 , asCsvF
 , asJsonSingleF
 , asJsonF
+, selectStarF
 
 , StatementT
 ) where
@@ -246,24 +248,27 @@ insertableValue :: JSON.Value -> T.Text
 insertableValue JSON.Null = "null"
 insertableValue v = insertableText $ unquoted v
 
-wrapQuery :: T.Text -> [T.Text] -> Maybe NonnegRange -> T.Text
+wrapQuery :: T.Text -> [T.Text] -> T.Text ->  Maybe NonnegRange -> T.Text
-wrapQuery source selectColumns range =
+wrapQuery source selectColumns returnSelect range =
   withSourceF source <>
   " SELECT " <>
   T.intercalate ", " selectColumns <>
   " " <>
-  fromF ( limitF range )
+  fromF returnSelect ( limitF range )
 
 
 -- query fragments
+sourceSubqueryName :: T.Text
+sourceSubqueryName = "pg_source"
+
 withSourceF :: T.Text -> T.Text
-withSourceF s = "WITH source AS (" <> s <>")"
+withSourceF s = "WITH " <> sourceSubqueryName <> " AS (" <> s <>")"
 
 countF :: T.Text
 countF = "pg_catalog.count(t)"
 
 countAllF :: T.Text
-countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM source) a )"
+countAllF = "(SELECT pg_catalog.count(1) FROM (SELECT * FROM " <> sourceSubqueryName <> ") a )"
 
 countNoneF :: T.Text
 countNoneF = "null"
@@ -283,7 +288,7 @@ asCsvHeaderF =
   "  FROM (" <>
   "    SELECT json_object_keys(r)::TEXT as k" <>
   "    FROM ( " <>
-  "      SELECT row_to_json(source) as r from source limit 1" <>
+  "      SELECT row_to_json(hh) as r from " <> sourceSubqueryName <> " as hh limit 1" <>
   "    ) s" <>
   "  ) a" <>
   ")"
@@ -291,8 +296,11 @@ asCsvHeaderF =
 asCsvBodyF :: T.Text
 asCsvBodyF = "coalesce(string_agg(substring(t::text, 2, length(t::text) - 2), '\n'), '')"
 
-fromF :: T.Text -> T.Text
+selectStarF :: T.Text
-fromF limit = "FROM (SELECT * FROM source " <> limit <> ") t"
+selectStarF = "SELECT * FROM " <> sourceSubqueryName
+
+fromF :: T.Text -> T.Text -> T.Text
+fromF sel limit = "FROM (" <> sel <> " " <> limit <> ") t"
 
 limitF :: Maybe NonnegRange -> T.Text
 limitF r  = "LIMIT " <> limit <> " OFFSET " <> offset
@@ -303,7 +311,7 @@ limitF r  = "LIMIT " <> limit <> " OFFSET " <> offset
 locationF :: [T.Text] -> T.Text
 locationF pKeys =
     "(" <>
-    " WITH s AS (SELECT row_to_json(source) as r from source limit 1)" <>
+    " WITH s AS (SELECT row_to_json(ss) as r from " <> sourceSubqueryName <> " as ss  limit 1)" <>
     " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <>
     " FROM s, json_each_text(s.r) AS json_data" <>
     (
@@ -391,7 +399,8 @@ pgFmtCondition table (Filter (col,jp) ops val) =
       _      -> ""
     valToStr v = case v of
       VText s -> pgFmtValue opCode s
-     VForeignKey (QualifiedIdentifier s _) (ForeignKey ft fc) -> pgFmtColumn (QualifiedIdentifier s ft) fc
+      VForeignKey (QualifiedIdentifier s _) (ForeignKey ft fc) -> pgFmtColumn qi fc
+        where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft
 
 pgFmtColumn :: QualifiedIdentifier -> T.Text -> T.Text
 pgFmtColumn table "*" = fromQi table <> ".*"

src/PostgREST/QueryBuilder.hs

@@ -12,7 +12,7 @@ import           Control.Applicative
 import           Data.Tree
 import           PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem,
                                     pgFmtIdent, pgFmtCondition,
-                                    insertableValue, orderF)
+                                    insertableValue, orderF, sourceSubqueryName)
 import           PostgREST.Types
 --import qualified Data.Vector       as V (empty)
 --import qualified Hasql.Backend     as B
@@ -47,8 +47,8 @@ getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) =
     toFilter :: Text -> Text -> FieldName -> FieldName -> Filter
     toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc))
 
-addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
+addJoinConditions :: Text -> ApiRequest -> Either Text ApiRequest
-addJoinConditions schema allColumns (Node (query, (t, r)) forest) =
+addJoinConditions schema (Node (query, (t, r)) forest) =
   case r of
     Nothing -> Node (updatedQuery, (t, r))  <$> updatedForest -- this is the root node
     Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel),(t,r)) <$> updatedForest
@@ -68,7 +68,7 @@ addJoinConditions schema allColumns (Node (query, (t, r)) forest) =
         parents = mapMaybe (getParents.rootLabel) forest
         getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
         getParents _ = Nothing
-    updatedForest = mapM (addJoinConditions schema allColumns) forest
+    updatedForest = mapM (addJoinConditions schema) forest
     addCond q con = q{where_=con ++ where_ q}
 
 -- requestToCountQuery :: Text -> ApiRequest -> PStmt
@@ -94,11 +94,24 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
   where
     --query = B.Stmt qStr V.empty True
     --qStr = Data.Text.unwords [
+    -- query = Data.Text.unwords [
+    --   ("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
+    --   "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
+    --   "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) tbls),
+    --   ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions,
+    --   orderF (fromMaybe [] ord)
+    --   ]
+    -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
+    -- of our WITH query part
+    tblSchema tbl = if tbl == sourceSubqueryName then "" else schema
+    qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl
+    toQi t = QualifiedIdentifier (tblSchema t) t
+
     query = Data.Text.unwords [
       ("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
-      "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
+      "SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
-      "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) tbls),
+      "FROM ", intercalate ", " (map (fromQi . toQi) tbls),
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions,
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
       orderF (fromMaybe [] ord)
       ]
     emptyOnNull val x = if null x then "" else val

test/Feature/InsertSpec.hs

@@ -19,7 +19,8 @@ import TestTypes(IncPK(..), CompoundPK(..))
 spec :: Spec
 spec = afterAll_ resetDb $ around withApp $ do
   describe "Posting new record" $ do
-    after_ (clearTable "menagerie") . it "accepts disparate json types" $ do
+    after_ (clearTable "menagerie") . context "disparate csv types" $ do
+      it "accepts disparate json types" $ do
         p <- post "/menagerie"
           [json| {
             "integer": 13, "double": 3.14159, "varchar": "testing!"
@@ -30,6 +31,27 @@ spec = afterAll_ resetDb $ around withApp $ do
           simpleBody p `shouldBe` ""
           simpleStatus p `shouldBe` created201
 
+      it "filters columns in result using &select" $ do
+        request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]
+          [json| {
+            "integer": 14, "double": 3.14159, "varchar": "testing!"
+          , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+          , "enum": "foo"
+          } |] `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|{"integer":14,"varchar":"testing!"}|]
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "application/json"]
+          }
+
+      it "includes related data after insert" $ do
+        request methodPost "/projects?select=id,name,clients(id,name)" [("Prefer", "return=representation")]
+          [str|{"id":5,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|{"id":5,"name":"New Project","clients":{"id":2,"name":"Apple"}}|]
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Type" <:> "application/json", "Location" <:> "/projects?id=eq.5"]
+          }
+
+
     context "with no pk supplied" $ do
       context "into a table with auto-incrementing pk" . after_ (clearTable "auto_incrementing_pk") $
         it "succeeds with 201 and link" $ do

test/Feature/QuerySpec.hs

@@ -11,6 +11,7 @@ import SpecHelper
 spec :: Spec
 spec =
   beforeAll (clearTable "items" >> createItems 15)
+   . beforeAll (clearProjectsTable)
    . beforeAll (clearTable "complex_items" >> createComplexItems)
    . beforeAll (clearTable "nullable_integer" >> createNullInteger)
    . beforeAll (

test/SpecHelper.hs

@@ -130,6 +130,13 @@ clearTable table = do
   void . liftIO $ H.session pool $ H.tx Nothing $
     H.unitEx $ B.Stmt ("delete from test."<>table) V.empty True
 
+clearProjectsTable :: IO ()
+clearProjectsTable = do
+  pool <- testPool
+  void . liftIO $ H.session pool $ H.tx Nothing $
+    H.unitEx $ B.Stmt ("delete from test.projects where id > 4") V.empty True
+
+
 createItems :: Int -> IO ()
 createItems n = do
   pool <- testPool