From 71ef03070e665c43d5b69b3eb31913bcc841704c Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Wed, 21 Oct 2015 12:46:01 +0300 Subject: [PATCH] POST path modified with internal data type but tests failing (no Location and data returned as array) --- src/PostgREST/App.hs | 237 +++++++++++++++++++++++++--------- src/PostgREST/Parsers.hs | 39 +----- src/PostgREST/QueryBuilder.hs | 37 +++++- src/PostgREST/Types.hs | 10 +- src/mock.hs | 43 ++++++ 5 files changed, 266 insertions(+), 100 deletions(-) create mode 100644 src/mock.hs diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 201a75aa0..e89357c62 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -1,13 +1,18 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -module PostgREST.App ( - app -, sqlError -, isSqlError -, contentTypeForAccept -, jsonH -, TableOptions(..) -) where +{-# LANGUAGE TupleSections #-} +module PostgREST.App where +-- module PostgREST.App ( +-- app +-- , sqlError +-- , isSqlError +-- , contentTypeForAccept +-- , 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.Maybe (fromMaybe, isJust, isNothing, +import Data.List (find, sortBy, delete, transpose) +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 - echoRequested = hasPrefer "return=representation" - parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value)) - parsed = if lookupHeader "Content-Type" == Just csvMT - then do - rows <- CSV.decode CSV.NoHeader reqBody - if V.null rows then Left "CSV requires header" - else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows)) - else eitherDecode reqBody >>= \val -> - case val of - Object obj -> Right . second V.singleton . V.unzip . V.fromList $ - M.toList obj - _ -> Left "Expecting single JSON object or CSV rows" - case parsed of - Left err -> return $ responseLBS status400 [] $ - encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)] - Right toBeInserted -> do - rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted - let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows - pKeys = map pkName $ filter (filterPk schema table) allPrKeys - responses = flip map inserted $ \obj -> do - let primaries = - if Prelude.null pKeys - 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 + let echoRequested = hasPrefer "return=representation" + case query of + Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e + Right q -> do + row <- H.maybeEx q + let (queryTotal, body) = fromMaybe (Just (0::Int), Just "" :: Maybe BL.ByteString) row + return $ responseLBS status201 + [jsonH] + $ if echoRequested then (fromMaybe "[]" body) else "" + -- let qt = qualify table + -- echoRequested = hasPrefer "return=representation" + -- parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value)) + -- parsed = if lookupHeader "Content-Type" == Just csvMT + -- then do + -- rows <- CSV.decode CSV.NoHeader reqBody + -- if V.null rows then Left "CSV requires header" + -- else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows)) + -- else eitherDecode reqBody >>= \val -> + -- case val of + -- Object obj -> Right . second V.singleton . V.unzip . V.fromList $ + -- M.toList obj + -- _ -> Left "Expecting single JSON object or CSV rows" + -- case parsed of + -- Left err -> return $ responseLBS status400 [] $ + -- encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)] + -- Right toBeInserted -> do + -- rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted + -- let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows + -- pKeys = map pkName $ filter (filterPk schema table) allPrKeys + -- responses = flip map inserted $ \obj -> do + -- let primaries = + -- if Prelude.null pKeys + -- 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] diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 5a59163d2..ba0d2bc24 100644 --- a/src/PostgREST/Parsers.hs +++ b/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 Data.List (delete, find) -import Data.Maybe +--import Control.Monad (join) +--import Data.List (delete, find) +--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") diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 96ce5079f..c0194b508 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/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 ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn table c <> pgFmtJsonPath jp <> " AS " <> cast <> " )" <> asJsonPath jp +pgFmtSelectItem table (f@(c, jp), Nothing) = pgFmtField table f <> asJsonPath jp +pgFmtSelectItem table (f@(c, jp), Just cast ) = "CAST (" <> pgFmtField table f <> " AS " <> cast <> " )" <> asJsonPath jp asJsonPath :: Maybe JsonPath -> Text asJsonPath Nothing = "" diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 51f219cf4..2dac663c1 100644 --- a/src/PostgREST/Types.hs +++ b/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 { - select::[SelectItem] -, from::[Text] -, where_::[Filter] -, order::Maybe [OrderTerm] -} deriving (Show, Eq) +data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] } + | Insert { into::Text, fields::[Field], values::[[Value]] } + | Update { into::Text, set::Map Field Value, where_::[Filter] } 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 diff --git a/src/mock.hs b/src/mock.hs new file mode 100644 index 000000000..411b3c309 --- /dev/null +++ b/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" + |}] + |]