Refacttoring

src/PostgREST/App.hs

@@ -57,7 +57,11 @@ import           Prelude
 app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
 app dbstructure conf reqBody req =
   case (path, verb) of
-
+    -- ([table], v) ->
+    --   case request of
+    --     Left e -> return $ responseLBS status400 [jsonH] $ cs e
+    --     Right (selectQuery, mutateQuery, isSingle) ->
+        
     ([table], "GET") ->
       if range == Just emptyRange
       then return $ responseLBS status416 [] "HTTP Range error"
@@ -83,13 +87,10 @@ app dbstructure conf reqBody req =
                     if Prelude.null canonical then "" else "?" <> cs canonical
                 )
               ] (fromMaybe "[]" body)
-
         where
             frm = fromMaybe 0 $ rangeOffset <$> range
-            request = parseRequest schema allRels table req reqBody
 
-    ([table], "POST") -> do
+    ([table], "POST") ->
-      let echoRequested = hasPrefer "return=representation"
       case request of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (selectQuery, mutateQuery, isSingle) -> do
@@ -103,12 +104,8 @@ app dbstructure conf reqBody req =
               (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
             ]
             $ if echoRequested then fromMaybe "[]" body else ""
-      where
-        request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
-        fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
 
-    ([table], "PATCH") -> do
+    ([_], "PATCH") ->
-      let echoRequested = hasPrefer "return=representation"
       case request of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (selectQuery, mutateQuery, _) -> do
@@ -122,11 +119,7 @@ app dbstructure conf reqBody req =
           return $ responseLBS s [contentTypeH, r]
             $ if echoRequested then fromMaybe "[]" body else ""
 
-      where
+    ([_], "DELETE") ->
-        request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
-        fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
-
-    ([table], "DELETE") ->
       case request of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (selectQuery, mutateQuery, _) -> do
@@ -137,10 +130,6 @@ app dbstructure conf reqBody req =
             then responseLBS status404 [] ""
             else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
 
-
-      where
-        request = parseRequest schema allRels table req reqBody
-
     (["rpc", proc], "POST") -> do
       let qi = QualifiedIdentifier schema (cs proc)
       exists <- doesProcExist schema proc
@@ -201,6 +190,8 @@ app dbstructure conf reqBody req =
     contentType   = fromMaybe "application/json" $ contentTypeForAccept accept
     isCsv         = contentType == csvMT
     contentTypeH  = (hContentType, contentType)
+    echoRequested = hasPrefer "return=representation"
+    request = parseRequest schema allRels (head path) req reqBody --TODO! is head safe?
 
 rangeStatus :: Int -> Int -> Maybe Int -> Status
 rangeStatus _ _ Nothing = status200
@@ -390,7 +381,12 @@ parseRequest schema allRels rootTableName httpRequest reqBody =
     allFilters = whereFilters qParams
     mutateFilters = filter (not . ( '.' `elem` ) . fst) allFilters -- update/delete filters can be only on the root table
     cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
-    selectApiRequest = augumentRequestWithJoin schema allRels
+    fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels
+    rels = case method of
+      "POST"  -> fakeSourceRelations ++ allRels
+      "PATCH" -> fakeSourceRelations ++ allRels
+      _       -> allRels
+    selectApiRequest = augumentRequestWithJoin schema rels
       =<< buildSelectApiRequest rootName sel filters (orderStr qParams)
       where
         sel = if method == "DELETE"

src/PostgREST/Parsers.hs

@@ -34,7 +34,6 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
     op = fst <$> opVal
     val = snd <$> opVal
 
-
 ws :: Parser Text
 ws = cs <$> many (oneOf " \t")
 
@@ -45,23 +44,21 @@ pTreePath :: Parser (Path,Field)
 pTreePath = do
   p <- pFieldName `sepBy1` pDelimiter
   jp <- optionMaybe ( string "->" >>  pJsonPath)
-  let pp = map cs p
+  return (init p, (last p, jp))
-      jpp = map cs <$> jp
-  return (init pp, (last pp, jpp))
 
 pFieldForest :: Parser [Tree SelectItem]
 pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
 
 pFieldTree :: Parser (Tree SelectItem)
-pFieldTree = try (Node <$> pSelect <*> ( char '(' *> pFieldForest <* char ')'))
+pFieldTree = try (Node <$> pSelect <*> between (char '(') (char ')') pFieldForest)
-      <|>    Node <$> pSelect <*> pure []
+          <|>     Node <$> pSelect <*> pure []
 
 pStar :: Parser Text
 pStar = cs <$> (string "*" *> pure ("*"::String))
 
 pFieldName :: Parser Text
 pFieldName =  cs <$> (many1 (letter <|> digit <|> oneOf "_")
-      <?> "field name (* or [a..z0..9_])")
+          <?> "field name (* or [a..z0..9_])")
 
 pJsonPathDelimiter :: Parser Text
 pJsonPathDelimiter = cs <$> (try (string "->>") <|> string "->")