Get the refactored code to compile (5 test failing)

src/PostgREST/App.hs

@@ -13,7 +13,7 @@ import           Control.Monad             (join)
 import           Data.Bifunctor            (first)
 import qualified Data.ByteString.Char8     as BS
 import qualified Data.ByteString.Lazy      as BL
-import qualified Data.Csv                  as CSV
+--import qualified Data.Csv                  as CSV
 import           Data.Functor.Identity
 import qualified Data.HashMap.Strict       as HM
 import           Data.List                 (find, sortBy, delete, transpose)
@@ -23,7 +23,8 @@ import           Data.Ranged.Ranges        (emptyRange, singletonRange)
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
 import           Data.Tree
-import qualified Data.Map as M
+import qualified Data.Map                  as M
+import qualified Data.Aeson                as JSON
 
 import           Text.Parsec.Error
 import           Text.ParserCombinators.Parsec (parse)
@@ -75,20 +76,22 @@ import           Prelude
 
 app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response
 app dbStructure conf reqBody req =
-  let schema = configSchema conf
+  let
-      intent = userIntent schema req reqBody
       -- TODO: blow up for Left values
       contentType = either (const ApplicationJSON) id (iAccepts intent)
-      contentTypeH = (hContentType, contentType) in
+      contentTypeS ct = case ct of
+        ApplicationJSON -> "application/json"
+        TextCSV -> "text/csv"
+      contentTypeH = (hContentType, contentTypeS contentType) in
 
   case (iAction intent, iTarget intent, iPayload intent) of
     (ActionUnknown _, _, _) -> return notFound
     (_, TargetUnknown _, _) -> return notFound
-    (_, _, PayloadParseError e) ->
+    (_, _, Just (PayloadParseError e)) ->
-      return $ responseLBS status400 [jsonH]
+      return $ responseLBS status400 [jsonH] $
-        (formatGeneralError "Cannot parse request payload" e)
+        cs (formatGeneralError "Cannot parse request payload" (cs e))
 
-    (ActionInfo, TargetIdent tSchema tTable, _) -> do
+    (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), _) -> do
       let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
           pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
           body = encode (TableOptions cols pkeys)
@@ -101,12 +104,16 @@ app dbStructure conf reqBody req =
       body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure))
       return $ responseLBS status200 [jsonH] $ cs body
 
-    (ActionInvoke, TargetIdent qi, PayloadJSON payload) -> do
+    (ActionInvoke, TargetIdent qi, Just (PayloadJSON payload)) -> do
-      exists <- doesProcExist (qiSchema qi) (qiName qi)
+      exists <- doesProcExist qi
       if exists
         then do
-          let call = B.Stmt "select " V.empty True <>
+          let p = case pp of
-                asJson (callProc qi payload)
+                    JSON.Object o -> o
+                    _ -> undefined
+                  where pp = V.head payload
+              call = B.Stmt "select " V.empty True <>
+                asJson (callProc qi p)
               jwtSecret = configJwtSecret conf
 
           bodyJson :: Maybe (Identity Value) <- H.maybeEx call
@@ -118,42 +125,77 @@ app dbStructure conf reqBody req =
                     else cs $ encode body)
         else return notFound
 
-    (ActionRead, TargetIdent qi, _) -> do
+    (ActionRead, TargetIdent qi, _) ->
-      let range = iRange intent
+      case selectQuery of
-          singular = iPreferSingular intent
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
-          selectQuery = requestToQuery schema <$> selectApiRequest
+        Right q -> do
-          q = createReadStatement selectQuery range singular
+          let range = iRange intent
-                (not $ iPreferCount intent) contentType
+              singular = iPreferSingular intent
-      if range == Just emptyRange
+              stm = createReadStatement q range singular
-      then return $ errResponse status416 "HTTP Range error"
+                    (iPreferCount intent) (contentType == TextCSV)
-      else do
+          if range == Just emptyRange
-        row <- H.maybeEx q
+          then return $ errResponse status416 "HTTP Range error"
-        let (tableTotal, queryTotal, _ , body) = extractQueryResult row
+          else do
-        if singular
+            row <- H.maybeEx stm
-        then return $ if queryTotal <= 0
+            let (tableTotal, queryTotal, _ , body) = extractQueryResult row
-          then responseLBS status404 [] ""
+            if singular
-          else responseLBS status200 [contentTypeH] (fromMaybe "{}" body)
+            then return $ if queryTotal <= 0
-        else do
+              then responseLBS status404 [] ""
-          let frm = fromMaybe 0 $ rangeOffset <$> range
+              else responseLBS status200 [contentTypeH] (fromMaybe "{}" body)
-              to = frm+queryTotal-1
+            else do
-              contentRange = contentRangeH frm to tableTotal
+              let frm = fromMaybe 0 $ rangeOffset <$> range
-              status = rangeStatus frm to tableTotal
+                  to = frm+queryTotal-1
-              canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
+                  contentRange = contentRangeH frm to tableTotal
-                . sortBy (comparing fst)
+                  status = rangeStatus frm to tableTotal
-                . map (join (***) cs)
+                  canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
-                . parseSimpleQuery
+                    . sortBy (comparing fst)
-                $ rawQueryString req
+                    . map (join (***) cs)
-          return $ responseLBS status
+                    . parseSimpleQuery
-            [contentTypeH, contentRange,
+                    $ rawQueryString req
-              ("Content-Location",
+              return $ responseLBS status
-                "/" <> cs (qiName qi) <>
+                [contentTypeH, contentRange,
-                  if Prelude.null canonical then "" else "?" <> cs canonical
+                  ("Content-Location",
-              )
+                    "/" <> cs (qiName qi) <>
-            ] (fromMaybe "[]" body)
+                      if Prelude.null canonical then "" else "?" <> cs canonical
-    (ActionCreate, TargetIdent qi, PayloadJSON payload) -> undefined
+                  )
-    (ActionUpdate, TargetIdent qi, PayloadJSON payload) -> undefined
+                ] (fromMaybe "[]" body)
-    (ActionDelete, TargetIdent qi, _) -> undefined
+    (ActionCreate, TargetIdent (QualifiedIdentifier _ table), _) ->
-    (ActionRead, TargetIdent qi, _) -> undefined
+      case queries of
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+        Right (sq,mq,isSingle) -> do
+          let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
+          let stm = createWriteStatement sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV)
+          row <- H.maybeEx stm
+          let (_, _, location, body) = extractQueryResult row
+          return $ responseLBS status201
+            [
+              contentTypeH,
+              (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
+            ]
+            $ if iPreferRepresentation intent then fromMaybe "[]" body else ""
+    (ActionUpdate, TargetIdent _, _) ->
+      case queries of
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+        Right (sq,mq,_) -> do
+          let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV)
+          row <- H.maybeEx stm
+          let (_, queryTotal, _, body) = extractQueryResult row
+              r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
+              s = case () of _ | queryTotal == 0 -> status404
+                               | iPreferRepresentation intent -> status200
+                               | otherwise -> status204
+          return $ responseLBS s [contentTypeH, r]
+            $ if iPreferRepresentation intent then fromMaybe "[]" body else ""
+    (ActionDelete, TargetIdent _, _) ->
+      case queries of
+        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+        Right (sq,mq,_) -> do
+          let stm = createWriteStatement sq mq False False [] (contentType == TextCSV)
+          row <- H.maybeEx stm
+          let (_, queryTotal, _, _) = extractQueryResult row
+          return $ if queryTotal == 0
+            then notFound
+            else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
 
     (_, _, _) -> return notFound
 
@@ -162,12 +204,20 @@ app dbStructure conf reqBody req =
   filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
   allPrKeys = dbPrimaryKeys dbStructure
   allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
+  schema = cs $ configSchema conf
+  intent = userIntent schema req reqBody
+  selectApiRequest = buildSelectApiRequest intent (dbRelations dbStructure)
+  selectQuery = requestToQuery schema <$> selectApiRequest
+  mutateTuple = buildMutateApiRequest intent
+  mutateApiRequest = fst <$> mutateTuple
+  isSingleRecord = snd <$> mutateTuple
+  mutateQuery = requestToQuery schema <$> mutateApiRequest
+  queries = (,,) <$> selectQuery <*> mutateQuery <*> isSingleRecord
   --   path          = pathInfo req
   --   verb          = requestMethod req
   --   hdrs          = requestHeaders req
   --   lookupHeader  = flip lookup hdrs
   --   hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs
-  --   schema        = cs $ configSchema conf
   --   range         = rangeRequested hdrs
   --   request = parseRequest schema (dbRelations dbStructure) (head path) req reqBody --TODO! is head safe?
 
@@ -253,17 +303,17 @@ contentTypeForAccept accept
     findInAccept = flip find $ parseHttpAccept acceptH
     has          = isJust . findInAccept . BS.isPrefixOf
 
-parseCsvCell :: BL.ByteString -> Value
+-- parseCsvCell :: BL.ByteString -> Value
-parseCsvCell s = if s == "NULL" then Null else String $ cs s
+-- parseCsvCell s = if s == "NULL" then Null else String $ cs s
 
 formatRelationError :: Text -> Text
-formatRelationError e = formatGeneralError
+formatRelationError = formatGeneralError
-  "could not find foreign keys between these entities" e
+  "could not find foreign keys between these entities"
 
 formatParserError :: ParseError -> Text
 formatParserError e = formatGeneralError message details
   where
-     message = show (errorPos e)
+     message = cs $ show (errorPos e)
      details = strip $ replace "\n" " " $ cs
        $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 
@@ -272,31 +322,31 @@ formatGeneralError message details = cs $ encode $ object [
   "message" .= message,
   "details" .= details]
 
-parseRequestBody :: Bool -> RequestBody -> Either Text ([Text],[[Value]])
+-- parseRequestBody :: Bool -> RequestBody -> Either Text ([Text],[[Value]])
-parseRequestBody isCsv reqBody = first cs $
+-- parseRequestBody isCsv reqBody = first cs $
-  checkStructure =<<
+--   checkStructure =<<
-  if isCsv
+--   if isCsv
-  then do
+--   then do
-    rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody
+--     rows <- (map V.toList . V.toList) <$> CSV.decode CSV.NoHeader reqBody
-    if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row)
+--     if null rows then Left "CSV requires header" -- TODO! should check if length rows > 1 (header and 1 row)
-      else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows))
+--       else Right (head rows, (map $ map $ parseCsvCell . cs) (tail rows))
-  else eitherDecode reqBody >>= convertJson
+--   else eitherDecode reqBody >>= convertJson
-  where
+--   where
-    checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]])
+--     checkStructure :: ([Text], [[Value]]) -> Either String ([Text], [[Value]])
-    checkStructure v
+--     checkStructure v
-      | headerMatchesContent v = Right v
+--       | headerMatchesContent v = Right v
-      | isCsv = Left "CSV header does not match rows length"
+--       | isCsv = Left "CSV header does not match rows length"
-      | otherwise = Left "The number of keys in objects do not match"
+--       | otherwise = Left "The number of keys in objects do not match"
+--
+--     headerMatchesContent :: ([Text], [[Value]]) -> Bool
+--     headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals
+--       where headerLength = length header
 
-    headerMatchesContent :: ([Text], [[Value]]) -> Bool
+convertJson :: Value -> Either Text ([Text],[[Value]])
-    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"
+    invalidMsg = "Expecting single JSON object or JSON array of objects"::Text
-    normalized :: Either String [(Text, [Value])]
+    normalized :: Either Text [(Text, [Value])]
     normalized = groupByKey =<< normalizeValue v
 
     vals :: [(Text, [Value])] -> [[Value]]
@@ -305,16 +355,16 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
     header :: [(Text, [Value])] -> [Text]
     header = map fst
 
-    groupByKey :: Value -> Either String [(Text,[Value])]
+    groupByKey :: Value -> Either Text [(Text,[Value])]
     groupByKey (Array a) = HM.toList . foldr (HM.unionWith (++)) (HM.fromList []) <$> maps
       where
-        maps :: Either String [HM.HashMap Text [Value]]
+        maps :: Either Text [HM.HashMap Text [Value]]
         maps = mapM getElems $ V.toList a
         getElems (Object o) = Right $ HM.map (:[]) o
         getElems _ = Left invalidMsg
     groupByKey _ = Left invalidMsg
 
-    normalizeValue :: Value -> Either String Value
+    normalizeValue :: Value -> Either Text Value
     normalizeValue val =
       case val of
         Object obj  -> Right $ Array (V.fromList[Object obj])
@@ -327,63 +377,104 @@ augumentRequestWithJoin schema allRels request =
   >>= 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 :: Request -> [(String, Maybe String)]
-queryParams httpRequest = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
+-- 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
 
-selectStr :: [(String, Maybe String)] -> String
+buildSelectApiRequest :: Intent -> [Relation] -> Either Text ApiRequest
-selectStr qParams = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
+buildSelectApiRequest intent allRels =
-
-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 -> Schema -> TableName  -> [(String, String)] ->  [Relation] -> [(String, Maybe String)] -> Either Text ApiRequest
-buildSelectApiRequest method schema rootTableName allFilters allRels qParams =
   augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts)
   where
-    selStr = selectStr qParams
+    selStr = iSelect intent
-    orderS = orderStr qParams
+    orderS = iOrder intent
-    rels = case method of
+    action = iAction intent
-      "POST"  -> fakeSourceRelations ++ allRels
+    target = iTarget intent
-      "PATCH" -> fakeSourceRelations ++ allRels
+    (schema, rootTableName) = fromJust $ -- Make it safe
-      _       -> allRels
+      case target of
-      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
+        (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
-    sel = if method == "DELETE"
+        _ -> Nothing
-      then "*" -- we are not returning the records so no need to consider nested items
+
-      else selStr
+    rootName = if action == ActionRead
-    rootName = if method == "GET"
       then rootTableName
       else sourceSubqueryName
-    filters = if method == "GET"
+    filters = if action == ActionRead
-      then allFilters
+      then iFilters intent
-      else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update
+      else filter (( '.' `elem` ) . fst) $ iFilters intent -- there can be no filters on the root table whre we are doing insert/update
-    apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++sel++">>") sel
+    rels = case action of
+      ActionCreate -> fakeSourceRelations ++ allRels
+      ActionUpdate -> fakeSourceRelations ++ allRels
+      _       -> allRels
+      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
+    apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
     addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
     flts = mapM pRequestFilter filters
     ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
 
-buildMutateApiRequest :: Text -> Bool -> TableName -> RequestBody -> [(String, String)] -> Either Text (ApiRequest, Bool)
+--buildMutateApiRequest :: Text -> Bool -> TableName -> RequestBody -> [(String, String)] -> Either Text (ApiRequest, Bool)
-buildMutateApiRequest method isCsv rootTableName reqBody allFilters =
+--buildMutateApiRequest method isCsv rootTableName reqBody allFilters =
+buildMutateApiRequest :: Intent -> Either Text (ApiRequest, Bool)
+buildMutateApiRequest intent =
   (,) <$> mutateApiRequest <*> pure isSingleRecord
   where
-    mutateApiRequest = case method of
+    action = iAction intent
-      "POST"   -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals)    <*> pure (rootTableName, Nothing)) <*> pure []
+    target = iTarget intent
-      "PATCH"  -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
+    rootTableName = fromJust $ -- Make it safe
-      "DELETE" -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure []
+      case target of
+        (TargetIdent (QualifiedIdentifier _ t) ) -> Just t
+        _ -> Nothing
+    mutateApiRequest = case action of
+      ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals)    <*> pure (rootTableName, Nothing)) <*> pure []
+      ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
+      ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure []
       _        -> Left "Unsupported HTTP verb"
     parseField f = parse pField ("failed to parse field <<"++f++">>") f
-    parsedBody = parseRequestBody isCsv reqBody
+    payload = case iPayload intent of
+      Just (PayloadJSON v) -> JSON.Array v
+      _ -> undefined --TODO! fix
+    parsedBody = convertJson payload -- TODO! either check structure or refactor to send json directly to postgres
     isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody
     flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody)
     vals = snd <$> parsedBody
-    mutateFilters = filter (not . ( '.' `elem` ) . fst) allFilters -- update/delete filters can be only on the root table
+    mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table
     cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
     setWith = if isSingleRecord
           then M.fromList <$> (zip <$> flds <*> (head <$> vals))
           else Left "Expecting a sigle CSV line with header or a JSON object"
 
+-- buildSelectApiRequest :: Text -> Schema -> TableName  -> [(String, String)] ->  [Relation] -> [(String, Maybe String)] -> Either Text ApiRequest
+-- buildSelectApiRequest method schema rootTableName allFilters allRels qParams =
+--   augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts)
+--   where
+--     selStr = selectStr qParams
+--     orderS = orderStr qParams
+--     rels = case method of
+--       "POST"  -> fakeSourceRelations ++ allRels
+--       "PATCH" -> fakeSourceRelations ++ allRels
+--       _       -> allRels
+--       where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
+--     sel = if method == "DELETE"
+--       then "*" -- we are not returning the records so no need to consider nested items
+--       else selStr
+--     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
+--     apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++sel++">>") sel
+--     addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
+--     flts = mapM pRequestFilter filters
+--     ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
+
+
 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) =
@@ -421,30 +512,30 @@ instance ToJSON TableOptions where
       "columns" .= tblOptcolumns t
     , "pkey"   .= tblOptpkey t ]
 
-createSelectQuery :: [Relation] -> QualifiedIdentifier -> SqlQuery
+-- createSelectQuery :: [Relation] -> QualifiedIdentifier -> SqlQuery
-createSelectQuery rels qi =
+-- createSelectQuery rels qi =
-  requestToQuery schema <$> selectApiRequest
+--   requestToQuery schema <$> selectApiRequest
-  undefined
+--   undefined
 
-parseRequest :: Schema -> [Relation] -> TableName -> Request -> RequestBody -> Either Text (SqlQuery, Maybe (SqlQuery, Bool))
+-- parseRequest :: Schema -> [Relation] -> TableName -> Request -> RequestBody -> Either Text (SqlQuery, Maybe (SqlQuery, Bool))
-parseRequest schema allRels rootTableName httpRequest reqBody =
+-- parseRequest schema allRels rootTableName httpRequest reqBody =
-  if method == "GET"
+--   if method == "GET"
-  then (,Nothing) <$> selectQuery
+--   then (,Nothing) <$> selectQuery
-  else (,) <$> selectQuery <*> (  Just <$> mutatePart  )
+--   else (,) <$> selectQuery <*> (  Just <$> mutatePart  )
-  where
+--   where
-    mutatePart = (,) <$> mutateQuery <*> isSingleRecord
+--     mutatePart = (,) <$> mutateQuery <*> isSingleRecord
-    hdrs = requestHeaders httpRequest
+--     hdrs = requestHeaders httpRequest
-    lookupHeader = flip lookup hdrs
+--     lookupHeader = flip lookup hdrs
-    isCsv = lookupHeader "Content-Type" == Just csvMT
+--     isCsv = lookupHeader "Content-Type" == Just csvMT
-    method = requestMethod httpRequest
+--     method = requestMethod httpRequest
-    qParams = queryParams httpRequest
+--     qParams = queryParams httpRequest
-    allFilters = whereFilters qParams
+--     allFilters = whereFilters qParams
-    selectApiRequest = buildSelectApiRequest (cs method) schema rootTableName allFilters allRels qParams
+--     selectApiRequest = buildSelectApiRequest (cs method) schema rootTableName allFilters allRels qParams
-    mutateTuple = buildMutateApiRequest (cs method) isCsv rootTableName reqBody allFilters
+--     mutateTuple = buildMutateApiRequest (cs method) isCsv rootTableName reqBody allFilters
-    mutateApiRequest = fst <$> mutateTuple
+--     mutateApiRequest = fst <$> mutateTuple
-    isSingleRecord = snd <$> mutateTuple
+--     isSingleRecord = snd <$> mutateTuple
-    selectQuery = requestToQuery schema <$> selectApiRequest
+--     selectQuery = requestToQuery schema <$> selectApiRequest
-    mutateQuery = requestToQuery schema <$> mutateApiRequest
+--     mutateQuery = requestToQuery schema <$> mutateApiRequest
 
 createReadStatement :: SqlQuery -> Maybe NonnegRange -> Bool -> Bool -> Bool -> B.Stmt P.Postgres
 createReadStatement selectQuery range isSingle countTable asCsv =

src/PostgREST/DbStructure.hs

@@ -51,7 +51,7 @@ doesProc stmt qi = do
   return $ isJust row
 
 doesProcExist :: QualifiedIdentifier -> H.Tx P.Postgres s Bool
-doesProcExist = doesProc $ [H.stmt|
+doesProcExist = doesProc [H.stmt|
       SELECT 1
       FROM   pg_catalog.pg_namespace n
       JOIN   pg_catalog.pg_proc p

src/PostgREST/RequestIntent.hs

@@ -7,7 +7,8 @@ import qualified Data.Csv                as CSV
 import           Data.List               (find)
 import qualified Data.HashMap.Strict     as M
 import           Data.Maybe              (fromMaybe, isJust, isNothing,
-                                          listToMaybe)
+                                          listToMaybe, fromJust)
+import           Control.Monad           (join)
 import           Data.Monoid             ((<>))
 import           Data.String.Conversions (cs)
 import qualified Data.Text               as T
@@ -23,14 +24,14 @@ type RequestBody = BL.ByteString
 data Action = ActionCreate | ActionRead
             | ActionUpdate | ActionDelete
             | ActionInfo   | ActionInvoke
-            | ActionUnknown BS.ByteString
+            | ActionUnknown BS.ByteString deriving Eq
 -- | The target db object of a user action
 data Target = TargetIdent QualifiedIdentifier
             | TargetRoot
             | TargetUnknown [T.Text]
 -- | Enumeration of currently supported content types for
 -- route responses and upload payloads
-data ContentType = ApplicationJSON | TextCSV
+data ContentType = ApplicationJSON | TextCSV deriving Eq
 -- | When Hasql supports the COPY command then we can
 -- have a special payload just for CSV, but until
 -- then CSV is converted to a JSON array.
@@ -54,19 +55,25 @@ data Intent = Intent {
   -- | The content type the client most desires (or JSON if undecided)
   , iAccepts :: Either BS.ByteString ContentType
   -- | Data sent by client and used for mutation actions
-  , iPayload :: Payload
+  , iPayload :: Maybe Payload
   -- | If client wants created items echoed back
   , iPreferRepresentation :: Bool
   -- | If client wants first row as raw object
   , iPreferSingular :: Bool
   -- | Whether the client wants a result count (slower)
   , iPreferCount :: Bool
+  -- | Filters on the result ("id", "eq.10")
+  , iFilters :: [(String, String)]
+  -- | &select parameter used to shape the response
+  , iSelect :: String
+  -- | &order parameter
+  , iOrder :: Maybe String
   }
 
 -- | Examines HTTP request and translates it into user intent.
 userIntent :: Schema -> Request -> RequestBody -> Intent
 userIntent schema req reqBody =
-  let action = case requestMethod req of
+  let action = case method of
                  "GET"     -> ActionRead
                  "POST"    -> if isTargetingProc
                                 then ActionInvoke
@@ -82,7 +89,11 @@ userIntent schema req reqBody =
                  ["rpc", proc] -> TargetIdent
                                   $ QualifiedIdentifier schema proc
                  other         -> TargetUnknown other
-      reqPayload = case pickContentType (lookupHeader "content-type") of
+      reqPayload = case action of
+        ActionCreate -> Just payload
+        ActionUpdate -> Just payload
+        _            -> Nothing
+        where payload = case pickContentType (lookupHeader "content-type") of
                      Right ApplicationJSON ->
                        either (PayloadParseError . cs)
                          (PayloadJSON . pluralize)
@@ -95,22 +106,32 @@ userIntent schema req reqBody =
                        PayloadParseError $
                          "Content-type not acceptable: " <> accept in
 
-  Intent action
+  Intent {
-    (if singular then Nothing else rangeRequested hdrs)
+    iAction = action
-    target
+  , iRange  = if singular then Nothing else rangeRequested hdrs
-    (pickContentType $ lookupHeader "accept")
+  , iTarget = target
-    reqPayload
+  , iAccepts = pickContentType $ lookupHeader "accept"
-    (hasPrefer "return=representation")
+  , iPayload = reqPayload
-    singular
+  , iPreferRepresentation = hasPrefer "return=representation"
-    (not $ hasPrefer "count=none")
+  , iPreferSingular = singular
+  , iPreferCount = not $ hasPrefer "count=none"
+  , iFilters = [ (k, fromJust v) | (k,v) <- qParams, k `notElem` ["select", "order"], isJust v ]
+  , iSelect = if method == "DELETE"
+              then "*"
+              else fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
+  , iOrder = join $ lookup "order" qParams
+  }
 
  where
   path            = pathInfo req
+  method          = requestMethod req
   isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
   hdrs            = requestHeaders req
+  qParams        = [(cs k, cs <$> v)|(k,v) <- queryString req]
   lookupHeader    = flip lookup hdrs
   hasPrefer val   = any (\(h,v) -> h == "Prefer" && v == val) hdrs
-  singular        = (hasPrefer "plurality=singular")
+  singular        = hasPrefer "plurality=singular"
+
 
 
 -- PRIVATE ---------------------------------------------------------------