Cleanup / Refactoring

src/PostgREST/App.hs

@@ -1,18 +1,11 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
-module PostgREST.App where
+--module PostgREST.App where
--- module PostgREST.App (
+module PostgREST.App (
---   app
+  app
--- , sqlError
+, contentTypeForAccept
--- , isSqlError
+) where
--- , contentTypeForAccept
--- , jsonH
--- , TableOptions(..)
--- , parsePostRequest
--- , rr
--- , bb
--- ) where
 
 import           Control.Applicative
 import           Control.Arrow             ((***))
@@ -72,26 +65,16 @@ app dbstructure conf reqBody req =
       if range == Just emptyRange
       then return $ responseLBS status416 [] "HTTP Range error"
       else
-        case query of
+        case request of
-          Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
+          Left e -> return $ responseLBS status400 [jsonH] $ cs e
-          Right qs -> do
+          Right (selectQuery, _, _) -> do
-            let q = B.Stmt
+            let q = B.Stmt (createStatement selectQuery Nothing True range [] (not $ hasPrefer "count=none") isCsv) V.empty True
-                    (
-                      wrapQuery qs [
-                        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
-                      ] selectStarF range
-                    )
-                    V.empty True
             row <- H.maybeEx q
-            let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
+            let (tableTotal, queryTotal, _ , body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString, Just "" :: Maybe BL.ByteString) row
                 to = frm+queryTotal-1
                 contentRange = contentRangeH frm to tableTotal
                 status = rangeStatus frm to tableTotal
-                canonical = urlEncodeVars
+                canonical = urlEncodeVars -- should this be moved to the db (location)?
                   . sortBy (comparing fst)
                   . map (join (***) cs)
                   . parseSimpleQuery
@@ -106,59 +89,26 @@ app dbstructure conf reqBody req =
 
         where
             frm = fromMaybe 0 $ rangeOffset <$> range
-            -- apiRequest = parseGetRequest table req
+            request = parseRequest schema allRels table req reqBody
-            --          >>= first formatRelationError . addRelations schema allRels Nothing
-            --          >>= addJoinConditions schema allCols
-            apiRequest = parseGetRequest table req >>= augumentRequestWithJoin schema allRels
-            query = requestToQuery schema <$> apiRequest
 
     ([table], "POST") -> do
       let echoRequested = hasPrefer "return=representation"
-      case queries of
+      case request of
-        Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
-        Right (qi, qs) -> do
+        Right (selectQuery, mutateQuery, isSingle) -> do
-          let isSingle = either (const False) id returnSingle
+          let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-              pKeys = map pkName $ filter (filterPk schema table) allPrKeys
+              q = B.Stmt (createStatement selectQuery (Just (mutateQuery, isSingle)) echoRequested Nothing pKeys False isCsv) V.empty True
-              q = B.Stmt
-                    (
-                      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"
-
-                      ] qs Nothing
-                    )
-                    V.empty True
-
           row <- H.maybeEx q
-          let (locationRaw, _ {-- queryTotal --}, bodyRaw) = fromMaybe (Just "" :: Maybe BL.ByteString, Just (0::Int), Just "" :: Maybe BL.ByteString) row
+          let (_, _, location, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString, Just "" :: Maybe BL.ByteString) row
-              body = fromMaybe "[]" bodyRaw
-              locationH = fromMaybe "" locationRaw
           return $ responseLBS status201
             [
               contentTypeH,
-              (hLocation, "/" <> cs table <> "?" <> cs locationH)
+              (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
             ]
-            $ if echoRequested then body else ""
+            $ if echoRequested then (fromMaybe "[]" body) else ""
       where
-        res = parsePostRequest table req reqBody
+        request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
-        ins = fst <$> res
-        insertApiRequest = snd <$> ins
-        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
@@ -186,46 +136,21 @@ app dbstructure conf reqBody req =
 
     ([table], "PATCH") -> do
       let echoRequested = hasPrefer "return=representation"
-      case queries of
+      case request of
-        Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
-        Right (qu, qs) -> do
+        Right (selectQuery, mutateQuery, _) -> do
-          let q = B.Stmt
+          let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) echoRequested Nothing [] False isCsv) V.empty True
-                    (
-                      wrapQuery qu [
-                        countF,
-                        if echoRequested
-                        then
-                          case contentType of
-                             "text/csv" -> asCsvF
-                             _     -> asJsonF
-                        else "null"
-
-                      ] qs Nothing
-                    )
-                    V.empty True
-
           row <- H.maybeEx q
-          let (queryTotal, bodyRaw) = fromMaybe (0::Int, Just "" :: Maybe BL.ByteString) row
+          let (_, queryTotal, _, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString, Just "" :: Maybe BL.ByteString) row
-              body = fromMaybe "[]" bodyRaw
               r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
               s = case () of _ | queryTotal == 0 -> status404
                                | echoRequested -> status200
                                | otherwise -> status204
-          --return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
+          return $ responseLBS s [contentTypeH, r]
-          return $ responseLBS s
+            $ if echoRequested then (fromMaybe "[]" body) else ""
-            [
-              contentTypeH,
-              r
-            ]
-            $ if echoRequested then body else ""
 
       where
-        res = parsePatchRequest table req reqBody
+        request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
-        updateApiRequest = fst <$> res
-        updateQuery = requestToQuery schema <$> updateApiRequest
-        selectApiRequest = (snd <$> res) >>= augumentRequestWithJoin schema (fakeSourceRelations ++ allRels)
-        selectQuery = requestToQuery schema <$> selectApiRequest
-        queries = (,) <$> updateQuery <*> selectQuery
         fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
 
     ([table], "DELETE") -> do
@@ -298,14 +223,9 @@ app dbstructure conf reqBody req =
     range         = rangeRequested hdrs
     allOrigins    = ("Access-Control-Allow-Origin", "*") :: Header
     contentType   = fromMaybe "application/json" $ contentTypeForAccept accept
+    isCsv         = contentType == csvMT
     contentTypeH  = (hContentType, contentType)
 
-sqlError :: t
-sqlError = undefined
-
-isSqlError :: t
-isSqlError = undefined
-
 rangeStatus :: Int -> Int -> Maybe Int -> Status
 rangeStatus _ _ Nothing = status200
 rangeStatus frm to (Just total)
@@ -347,11 +267,6 @@ contentTypeForAccept accept
     findInAccept = flip find $ parseHttpAccept acceptH
     has          = isJust . findInAccept . BS.isPrefixOf
 
-bodyForAccept :: BS.ByteString -> QualifiedIdentifier  -> StatementT
-bodyForAccept contentType table
-  | contentType == csvMT = asCsvWithCount table
-  | otherwise = asJsonWithCount -- defaults to JSON
-
 handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
               -> H.Tx P.Postgres s Response
 handleJsonObj reqBody handler = do
@@ -376,6 +291,7 @@ 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,
@@ -385,54 +301,6 @@ formatParserError e = cs $ encode $ object [
      details = strip $ replace "\n" " " $ cs
        $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 
-parsePatchRequest :: NodeName -> Request -> BL.ByteString -> Either Text (ApiRequest, ApiRequest)
-parsePatchRequest rootTableName httpRequest reqBody =
-  (,) <$> updateApiRequest <*> returnApiRequest
-  where
-    updateApiRequest = Node <$> apiNode <*> pure []
-    apiNode = (,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)
-    flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsed)
-    vals = head.snd <$> parsed -- TODO! cheack if head is safe here
-    parseField f = parse pField ("failed to parse field <<"++f++">>") f
-    parsed :: Either Text ([Text],[[Value]])
-    parsed = parseRequestBody isCsv reqBody
-    returnSingle = (==1) . length . snd <$> parsed
-    isSingle = either (const False) id returnSingle
-    setWith = if isSingle
-          then M.fromList <$> (zip <$> flds <*> vals)
-          else Left "Expecting a sigle CSV line with header or a JSON object"
-    hdrs          = requestHeaders httpRequest
-    lookupHeader  = flip lookup hdrs
-    --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
-    isCsv = lookupHeader "Content-Type" == Just csvMT
-    qParams = queryParams httpRequest
-    selectFilters = filter (( '.' `elem` ) . fst) $ whereFilters qParams -- there can be no filters on the root table whre we are doing insert
-    updateFilters = filter (not . ( '.' `elem` ) . fst) $ whereFilters qParams -- update filters can be only on the root table
-    returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) selectFilters (orderStr qParams)
-    cond = first formatParserError $ map snd <$> mapM pRequestFilter updateFilters
-
--- quite ugly return type
-parsePostRequest :: NodeName -> Request -> BL.ByteString -> Either Text ((Bool, ApiRequest), ApiRequest)
-parsePostRequest rootTableName httpRequest reqBody =
-  (,) <$> ((,) <$> returnSingle <*> insertApiRequest) <*> returnApiRequest
-  where
-    insertApiRequest = Node <$> apiNode <*> pure []
-    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 = parseRequestBody isCsv reqBody
-    returnSingle = (==1) . length . snd <$> parsed -- not quite correct qhen the user send single row but in an array
-    hdrs          = requestHeaders httpRequest
-    lookupHeader  = flip lookup hdrs
-    --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
-    isCsv = lookupHeader "Content-Type" == Just csvMT
-    qParams = queryParams httpRequest
-    filters = filter (( '.' `elem` ) . fst) $ whereFilters qParams -- there can be no filters on the root table whre we are doing insert
-    returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) filters (orderStr qParams)
-
-
 parseRequestBody :: Bool -> BL.ByteString -> Either Text ([Text],[[Value]])
 parseRequestBody isCsv reqBody = first cs $
   checkStructure =<<
@@ -448,13 +316,6 @@ parseRequestBody isCsv reqBody = first cs $
       | headerMatchesContent v = Right v
       | isCsv = Left "CSV header does not match rows length"
       | otherwise = Left "The number of keys in objects do not match"
-    -- checkStructure 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"
 
     headerMatchesContent :: ([Text], [[Value]]) -> Bool
     headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals
@@ -489,12 +350,6 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
         a@(Array _) -> Right a
         _ -> Left invalidMsg
 
-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 =
   (first formatRelationError . addRelations schema allRels Nothing) request
@@ -553,3 +408,62 @@ instance ToJSON TableOptions where
   toJSON t = object [
       "columns" .= tblOptcolumns t
     , "pkey"   .= tblOptpkey t ]
+
+parseRequest :: Text -> [Relation] -> NodeName -> Request -> BL.ByteString -> Either Text (Text, Text, Bool)
+parseRequest schema allRels rootTableName httpRequest reqBody =
+  (,,) <$> selectQuery
+       <*> (if method == "GET" then pure "" else mutateQuery)
+       <*> (if method == "GET" then pure False else pure isSingleRecord)
+  where
+    hdrs = requestHeaders httpRequest
+    lookupHeader = flip lookup hdrs
+    isCsv = lookupHeader "Content-Type" == Just csvMT
+    method = requestMethod httpRequest
+    qParams = queryParams httpRequest
+    parsedBody = parseRequestBody isCsv reqBody
+    isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody
+    parseField f = parse pField ("failed to parse field <<"++f++">>") f
+    flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody)
+    vals = snd <$> parsedBody
+    setWith = if isSingleRecord
+          then M.fromList <$> (zip <$> flds <*> (head <$> vals))
+          else Left "Expecting a sigle CSV line with header or a JSON object"
+    allFilters = whereFilters qParams
+    updateFilters = filter (not . ( '.' `elem` ) . fst) $ allFilters -- update filters can be only on the root table
+    cond = first formatParserError $ map snd <$> mapM pRequestFilter updateFilters
+    selectApiRequest = augumentRequestWithJoin schema allRels
+      =<< buildSelectApiRequest rootName (selectStr qParams) filters (orderStr qParams)
+      where
+        rootName = if method == "GET"
+          then rootTableName
+          else sourceSubqueryName
+        filters = if method == "GET"
+          then allFilters
+          else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update
+    selectQuery = requestToQuery schema <$> selectApiRequest
+    mutateQuery = requestToQuery schema <$> case method of
+      "POST"  -> (Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals)    <*> pure (rootTableName, Nothing)) <*> pure [])
+      "PATCH" -> (Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [])
+      _       -> undefined
+
+createStatement :: Text -> Maybe (Text, Bool) -> Bool -> Maybe NonnegRange -> [Text] -> Bool -> Bool -> Text
+createStatement selectQuery Nothing _ range _ countTable asCsv =
+  wrapQuery selectQuery [
+    if countTable then countAllF else countNoneF,
+    countF,
+    "null", -- location header can not be calucalted
+    if asCsv then asCsvF else asJsonF
+  ] selectStarF range
+createStatement selectQuery (Just (changeQuery, isSingle)) echoRequested _ pKeys _ asCsv =
+  wrapQuery changeQuery [
+    countNoneF, -- when updateing it does not make sense
+    countF,
+    if isSingle then locationF pKeys else "null",
+    if echoRequested
+    then
+      if asCsv
+      then asCsvF
+      else if isSingle then asJsonSingleF else asJsonF
+    else "null"
+
+  ] selectQuery Nothing

src/PostgREST/QueryBuilder.hs

@@ -15,15 +15,11 @@ import           PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem,
                                     insertableValue, orderF, sourceSubqueryName, pgFmtJsonPath)
 import           PostgREST.Types
 import qualified Data.Map as M
---import qualified Data.Vector       as V (empty)
---import qualified Hasql.Backend     as B
 
 findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
 findRelation allRelations s t1 t2 =
   find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
 
-
-
 addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
 addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
   case parentNode of
@@ -72,45 +68,18 @@ addJoinConditions schema (Node (query, (t, r)) forest) =
     updatedForest = mapM (addJoinConditions schema) forest
     addCond q con = q{where_=con ++ where_ q}
 
--- requestToCountQuery :: Text -> ApiRequest -> PStmt
--- requestToCountQuery schema (Node (Select _ _ conditions _, (mainTbl, _)) _) =
---   B.Stmt query V.empty True
---   where
---     query = Data.Text.unwords [
---       "SELECT pg_catalog.count(1)",
---       "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
---       ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions
---       ]
---     emptyOnNull val x = if null x then "" else val
---     localConditions = filter fn conditions
---       where
---         fn  (Filter{value=VText _}) = True
---         fn  (Filter{value=VForeignKey _ _}) = False
-
---requestToQuery :: Text -> ApiRequest -> PStmt
 emptyOnNull :: Text -> [a] -> Text
 emptyOnNull val x = if null x then "" else val
 
 requestToQuery :: Text -> ApiRequest -> Text
 requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
-  --orderT (fromMaybe [] ord)  query
   query
   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 qi) colSelects ++ selects),
@@ -118,7 +87,6 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
       ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
       orderF (fromMaybe [] ord)
       ]
-
     (withs, selects) = foldr getQueryParts ([],[]) forest
     getQueryParts :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
     getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
@@ -127,26 +95,20 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
            <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
            <> "FROM (" <> subquery <> ") " <> table
            <> ") AS " <> table
-           --where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
            where subquery = requestToQuery schema (Node n forst)
-
     getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
       where
         sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
         wit = table <> " AS ( " <> subquery <> " )"
-          --where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
           where subquery = requestToQuery schema (Node n forst)
-
     getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
       where
         sel = "("
            <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
            <> "FROM (" <> subquery <> ") " <> table
            <> ") AS " <> table
-           --where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
            where subquery = requestToQuery schema (Node n forst)
-
+    --the following is just to remove the warning
-    -- 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 (Node (_,(_,Nothing)) _) _ = undefined