POST path modified with internal data type but tests failing (no Location and data returned as array)

src/PostgREST/App.hs

@@ -1,13 +1,18 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-module PostgREST.App (
+{-# LANGUAGE TupleSections #-}
-  app
+module PostgREST.App where
-, sqlError
+-- module PostgREST.App (
-, isSqlError
+--   app
-, contentTypeForAccept
+-- , sqlError
-, jsonH
+-- , isSqlError
-, TableOptions(..)
+-- , contentTypeForAccept
-) where
+-- , jsonH
+-- , TableOptions(..)
+-- , parsePostRequest
+-- , rr
+-- , bb
+-- ) where
 
 import qualified Blaze.ByteString.Builder  as BB
 import           Control.Applicative
@@ -20,24 +25,29 @@ import           Data.CaseInsensitive      (original)
 import qualified Data.Csv                  as CSV
 import           Data.Functor.Identity
 import qualified Data.HashMap.Strict       as M
-import           Data.List                 (find, sortBy)
+import           Data.List                 (find, sortBy, delete, transpose)
-import           Data.Maybe                (fromMaybe, 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
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
+import           Data.Tree
+--import           Data.Foldable             (forlrM)
 
 import           Text.Parsec.Error
+import           Text.ParserCombinators.Parsec (parse)
 
 import           Network.HTTP.Base         (urlEncodeVars)
 import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
 import           Network.HTTP.Types.URI    (parseSimpleQuery)
 import           Network.Wai
-import           Network.Wai.Internal      (Response (..))
+--import           Network.Wai.Internal
+import           Network.Wai.Internal      (Response (..), Request (..))
 import           Network.Wai.Parse         (parseHttpAccept)
+import Text.Heredoc
 
 import           Data.Aeson
 import           Data.Monoid
@@ -112,25 +122,12 @@ app dbstructure conf authenticator reqBody dbrole req =
             apiRequest = first formatParserError (parseGetRequest req)
                      >>= first formatRelationError . addRelations schema allRels Nothing
                      >>= addJoinConditions schema allCols
-                     where
+
-                       formatRelationError :: Text -> Text
-                       formatRelationError e = cs $ encode $ object [
-                         "mesage" .= ("could not find foreign keys between these entities"::String),
-                         "details" .= e]
-                       formatParserError :: ParseError -> Text
-                       formatParserError e = cs $ encode $ object [
-                         "message" .= message,
-                         "details" .= details]
-                         where
-                           message = show (errorPos e)
-                           details = strip $ replace "\n" " " $ cs
-                             $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 
             query = requestToQuery schema <$> apiRequest
             countQuery = requestToCountQuery schema <$> apiRequest
             queries = (,) <$> query <*> countQuery
 
-
     (["postgrest", "users"], "POST") -> do
       let user = decode reqBody :: Maybe AuthUser
 
@@ -166,39 +163,57 @@ app dbstructure conf authenticator reqBody dbrole req =
                   encode . object $ [("message", String "Failed authentication.")]
 
     ([table], "POST") -> do
-      let qt = qualify table
+      let echoRequested = hasPrefer "return=representation"
-          echoRequested = hasPrefer "return=representation"
+      case query of
-          parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
+        Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
-          parsed = if lookupHeader "Content-Type" == Just csvMT
+        Right q -> do
-            then do
+          row <- H.maybeEx q
-              rows <- CSV.decode CSV.NoHeader reqBody
+          let (queryTotal, body) = fromMaybe (Just (0::Int), Just "" :: Maybe BL.ByteString) row
-              if V.null rows then Left "CSV requires header"
+          return $ responseLBS status201
-                else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
+            [jsonH]
-            else eitherDecode reqBody >>= \val ->
+            $ if echoRequested then (fromMaybe "[]" body) else ""
-              case val of
+        -- let qt = qualify table
-                Object obj -> Right .  second V.singleton .  V.unzip .  V.fromList $
+      --     echoRequested = hasPrefer "return=representation"
-                  M.toList obj
+      --     parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
-                _ -> Left "Expecting single JSON object or CSV rows"
+      --     parsed = if lookupHeader "Content-Type" == Just csvMT
-      case parsed of
+      --       then do
-        Left err -> return $ responseLBS status400 [] $
+      --         rows <- CSV.decode CSV.NoHeader reqBody
-          encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
+      --         if V.null rows then Left "CSV requires header"
-        Right toBeInserted -> do
+      --           else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
-          rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
+      --       else eitherDecode reqBody >>= \val ->
-          let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
+      --         case val of
-              pKeys = map pkName $ filter (filterPk schema table) allPrKeys
+      --           Object obj -> Right .  second V.singleton .  V.unzip .  V.fromList $
-              responses = flip map inserted $ \obj -> do
+      --             M.toList obj
-                let primaries =
+      --           _ -> Left "Expecting single JSON object or CSV rows"
-                      if Prelude.null pKeys
+      -- case parsed of
-                        then obj
+      --   Left err -> return $ responseLBS status400 [] $
-                        else M.filterWithKey (const . (`elem` pKeys)) obj
+      --     encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
-                let params = urlEncodeVars
+      --   Right toBeInserted -> do
-                      $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
+      --     rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
-                      $ sortBy (comparing fst) $ M.toList primaries
+      --     let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
-                responseLBS status201
+      --         pKeys = map pkName $ filter (filterPk schema table) allPrKeys
-                  [ jsonH
+      --         responses = flip map inserted $ \obj -> do
-                  , (hLocation, "/" <> cs table <> "?" <> cs params)
+      --           let primaries =
-                  ] $ if echoRequested then encode obj else ""
+      --                 if Prelude.null pKeys
-          return $ multipart status201 responses
+      --                   then obj
+      --                   else M.filterWithKey (const . (`elem` pKeys)) obj
+      --           let params = urlEncodeVars
+      --                 $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
+      --                 $ sortBy (comparing fst) $ M.toList primaries
+      --           responseLBS status201
+      --             [ jsonH
+      --             , (hLocation, "/" <> cs table <> "?" <> cs params)
+      --             ] $ if echoRequested then encode obj else ""
+      --     return $ multipart status201 responses
+
+      where
+        apiRequest = parsePostRequest req reqBody
+        insertQuery = requestToQuery schema <$> apiRequest
+        query = withT
+            <$> insertQuery
+            <*> pure "t"
+            <*> pure (B.Stmt "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying" V.empty True)
+
 
     (["rpc", proc], "POST") -> do
       let qi = QualifiedIdentifier schema (cs proc)
@@ -391,6 +406,112 @@ multipart s rs =
     renderResponseBody _ = error
       "Unable to create multipart response from non-ResponseBuilder"
 
+
+formatRelationError :: Text -> Text
+formatRelationError e = cs $ encode $ object [
+  "mesage" .= ("could not find foreign keys between these entities"::String),
+  "details" .= e]
+formatParserError :: ParseError -> Text
+formatParserError e = cs $ encode $ object [
+  "message" .= message,
+  "details" .= details]
+  where
+     message = show (errorPos e)
+     details = strip $ replace "\n" " " $ cs
+       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+--parsePostRequest :: Request -> BL.ByteString -> Either String (V.Vector Text, V.Vector (V.Vector Value))
+parsePostRequest :: Request -> BL.ByteString -> Either Text ApiRequest
+parsePostRequest httpRequest reqBody =
+  Node <$> apiNode <*> pure []
+  where
+    apiNode = (,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)
+    flds =  join $ first formatParserError . (mapM (parseField . cs)) <$> (fst <$> parsed)
+    vals = snd <$> parsed
+    parseField f = parse pField ("failed to parse field <<"++f++">>") f
+    parsed :: Either Text ([Text],[[Value]])
+    parsed = first cs $
+      (\v->
+        if headerMatchesContent v
+        then Right v
+        else
+          if isCsv
+          then Left "CSV header does not match rows length"
+          else Left "The number of keys in objects do not match"
+      ) =<<
+      if isCsv
+      then do
+        rows <- (map (V.toList) . V.toList) <$> CSV.decode CSV.NoHeader reqBody
+        if null rows then Left "CSV requires header"
+          else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows))
+      else eitherDecode reqBody >>= \val -> convertJson val
+    hdrs          = requestHeaders httpRequest
+    lookupHeader  = flip lookup hdrs
+    rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
+    isCsv = lookupHeader "Content-Type" == Just csvMT
+
+headerMatchesContent :: ([Text], [[Value]]) -> Bool
+headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals
+  where headerLength = length header
+
+convertJson :: Value -> Either String ([Text],[[Value]])
+convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
+  where
+    invalidMsg = "Expecting single JSON object or JSON array of objects"
+    normalized :: Either String [(Text, [Value])]
+    normalized = groupByKey =<< normalizeValue v
+
+    vals :: [(Text, [Value])] -> [[Value]]
+    vals a = transpose $ map snd a
+
+    header :: [(Text, [Value])] -> [Text]
+    header = map fst
+
+    groupByKey :: Value -> Either String [(Text,[Value])]
+    groupByKey (Array a) = M.toList . foldr (M.unionWith (++)) (M.fromList []) <$> maps
+      where
+        maps :: Either String [M.HashMap Text [Value]]
+        maps = mapM getElems $ V.toList a
+        getElems (Object o) = Right $ M.map (\x->[x]) o
+        getElems _ = Left invalidMsg
+    groupByKey _ = Left invalidMsg
+
+    normalizeValue :: Value -> Either String Value
+    normalizeValue val =
+      case val of
+        Object obj  -> Right $ Array (V.fromList[Object obj])
+        a@(Array _) -> Right a
+        _ -> Left invalidMsg
+
+parseGetRequest :: Request -> Either ParseError ApiRequest
+parseGetRequest httpRequest =
+  foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
+  where
+    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
+    addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
+    flts = mapM pRequestFilter whereFilters
+    rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
+    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
+addFilter (path, flt) (Node rn forest) =
+  case targetNode of
+    Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
+    Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
+  where
+    targetNodeName:remainingPath = path
+    (targetNode,restForest) = splitForest targetNodeName forest
+    splitForest name forst =
+      case maybeNode of
+        Nothing -> (Nothing,forest)
+        Just node -> (Just node, delete node forest)
+      where maybeNode = find ((name==).fst.snd.rootLabel) forst
+
+
 data TableOptions = TableOptions {
   tblOptcolumns :: [Column]
 , tblOptpkey    :: [Text]

src/PostgREST/Parsers.hs

@@ -1,6 +1,6 @@
 module PostgREST.Parsers
-( parseGetRequest
+-- ( parseGetRequest
-)
+-- )
 where
 
 import           Control.Applicative hiding ((<$>))
@@ -8,29 +8,16 @@ import           Control.Applicative hiding ((<$>))
 import           Data.Functor ((<$>))
 import           Data.Traversable (traverse)
 
-import           Control.Monad                 (join)
+--import           Control.Monad                 (join)
-import           Data.List                     (delete, find)
+--import           Data.List                     (delete, find)
-import           Data.Maybe
+--import           Data.Maybe
 import           Data.Monoid
 import           Data.String.Conversions       (cs)
 import           Data.Text                     (Text)
 import           Data.Tree
-import           Network.Wai                   (Request, pathInfo, queryString)
+--import           Network.Wai                   (Request, pathInfo, queryString)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
-parseGetRequest :: Request -> Either ParseError ApiRequest
-parseGetRequest httpRequest =
-  foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
-  where
-    apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
-    addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
-    flts = mapM pRequestFilter whereFilters
-    rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
-    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 ]
 
 pRequestSelect :: Text -> Parser ApiRequest
 pRequestSelect rootNodeName = do
@@ -53,20 +40,6 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
     op = fst <$> opVal
     val = snd <$> opVal
 
-addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
-addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest
-addFilter (path, flt) (Node rn forest) =
-  case targetNode of
-    Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
-    Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
-  where
-    targetNodeName:remainingPath = path
-    (targetNode,restForest) = splitForest targetNodeName forest
-    splitForest name forst =
-      case maybeNode of
-        Nothing -> (Nothing,forest)
-        Just node -> (Just node, delete node forest)
-      where maybeNode = find ((name==).fst.snd.rootLabel) forst
 
 ws :: Parser Text
 ws = cs <$> many (oneOf " \t")

src/PostgREST/QueryBuilder.hs

@@ -12,7 +12,7 @@ import           Control.Applicative
 import           Data.Tree
 import           PostgREST.PgQuery (PStmt, fromQi,
                                     orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
-                                    pgFmtValue, whiteList)
+                                    pgFmtValue, whiteList, insertableValue)
 import           PostgREST.Types
 import qualified Data.Vector       as V (empty)
 import qualified Hasql.Backend     as B
@@ -126,6 +126,34 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
     --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
     --posible relations are Child Parent Many
     getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
+requestToQuery schema (Node (Insert tbl flds vals, (mainTbl, _)) forest) =
+  query
+  where
+    query = B.Stmt qStr V.empty True
+    qi = QualifiedIdentifier schema mainTbl
+    qStr = Data.Text.unwords [
+      "INSERT INTO ", fromQi qi,
+      " (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
+      "VALUES " <> intercalate ", "
+        ( map (\v ->
+            "(" <>
+            intercalate ", " ( map insertableValue v ) <>
+            ")"
+          ) vals
+        ),
+      "RETURNING " <> fromQi qi <> ".*"
+      ]
+    -- ("insert into " <> fromQi t <> " (" <>
+    --   T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>
+    --   ") values "
+    --   <> T.intercalate ", "
+    --     (V.toList $ V.map (\v -> "("
+    --         <> T.intercalate ", " (V.toList $ V.map insertableValue v)
+    --         <> ")"
+    --       ) vals
+    --     )
+    --   <> " returning row_to_json(" <> fromQi t <> ".*)")
+
 
 pgFmtCondition :: QualifiedIdentifier -> Filter -> Text
 pgFmtCondition table (Filter (col,jp) ops val) =
@@ -159,9 +187,12 @@ pgFmtJsonPath _ = ""
 pgFmtTable :: Table -> Text
 pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n
 
+pgFmtField :: QualifiedIdentifier -> Field -> Text
+pgFmtField table (c, jp) = pgFmtColumn table c <> pgFmtJsonPath jp
+
 pgFmtSelectItem :: QualifiedIdentifier -> SelectItem -> Text
-pgFmtSelectItem table ((c, jp), Nothing) = pgFmtColumn table c <> pgFmtJsonPath jp <> asJsonPath jp
+pgFmtSelectItem table (f@(c, jp), Nothing) = pgFmtField table f <> asJsonPath jp
-pgFmtSelectItem table ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp
+pgFmtSelectItem table (f@(c, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> asJsonPath jp
 
 asJsonPath :: Maybe JsonPath -> Text
 asJsonPath Nothing = ""

src/PostgREST/Types.hs

@@ -3,6 +3,7 @@ import Data.Text
 import Data.Tree
 import qualified Data.ByteString.Char8 as BS
 import Data.Aeson
+import Data.Map
 
 data DbStructure = DbStructure {
   tables :: [Table]
@@ -78,12 +79,9 @@ type Cast = Text
 type NodeName = Text
 type SelectItem = (Field, Maybe Cast)
 type Path = [Text]
-data Query = Select {
+data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] }
-  select::[SelectItem]
+           | Insert { into::Text, fields::[Field], values::[[Value]] }
-, from::[Text]
+           | Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq)
-, where_::[Filter]
-, order::Maybe [OrderTerm]
-} deriving (Show, Eq)
 data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
 type ApiNode = (Query, (NodeName, Maybe Relation))
 type ApiRequest = Tree ApiNode

src/mock.hs

@@ -0,0 +1,43 @@
+arr = eitherDecode "[{\"a\":10},{\"a\":20}]" :: Either String Value
+ob = eitherDecode "{\"a\":10}"::Either String Value
+
+rc :: Request
+rc =  Request {
+  -- | Request method such as GET.
+     requestMethod = "POST"
+  ,  pathInfo = ["menagerie"]
+  ,  requestHeaders = [("Content-Type", "text/csv")] --      :: H.RequestHeaders
+  }
+bc :: BL.ByteString
+bc = [str|integer->sub->sub2,double,varchar,boolean,date,money,enum
+         |13,3.14159,testing!,false,1900-01-01,$3.99,foo
+         |12,0.1,NULL,true,1929-10-01,12,bar
+         |]
+
+rj :: Request
+rj =  Request {
+ -- | Request method such as GET.
+     requestMethod = "POST"
+  ,  pathInfo = ["menagerie"]
+  ,  requestHeaders = [("Content-Type", "application/json")] --      :: H.RequestHeaders
+  }
+bj :: BL.ByteString
+bj = [str|{
+         |  "integer->sub->>sub2": 13, "double": 3.14159, "varchar": "testing!"
+         |  , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+         |  , "enum": "foo"
+         |}
+         |]
+bj2 :: BL.ByteString
+bj2 = [str|[
+          |{
+          |  "integer->sub->>sub2": 13, "double": 3.14159, "varchar": "testing!"
+          |  , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+          |  , "enum": "foo"
+          |},
+          |{
+          |  "integer->sub->>sub2": 13, "double": 3.14159, "varchar": "testing!"
+          |  , "boolean": false, "date": "1900-01-01", "money": "$3.99"
+          |  , "enum": "foo"
+          |}]
+          |]