WIP: converting App

src/PostgREST/App.hs

@@ -47,6 +47,9 @@ import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.Parsers
 import           PostgREST.DbStructure
 import           PostgREST.RangeQuery
+import           PostgREST.RequestIntent   (Intent(..), ContentType(..)
+                                            , Action(..), Target(..)
+                                            , Payload(..), userIntent)
 import           PostgREST.Types
 import           PostgREST.Auth            (tokenJWT)
 import           PostgREST.Error           (errResponse)
@@ -72,89 +75,42 @@ import           Prelude
 
 app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s Response
 app dbStructure conf reqBody req =
-  case (path, verb) of
+  let schema = configSchema conf
-    ([table], "OPTIONS") -> do
+      intent = userIntent schema req reqBody
-      let cols = filter (filterCol schema table) $ dbColumns dbStructure
+      -- TODO: blow up for Left values
-          pkeys = map pkName $ filter (filterPk schema table) allPrKeys
+      contentType = either (const ApplicationJSON) id (iAccepts intent)
+      contentTypeH = (hContentType, contentType) in
+
+  case (iAction intent, iTarget intent, iPayload intent) of
+    (ActionUnknown _, _, _) -> return notFound
+    (_, TargetUnknown _, _) -> return notFound
+    (_, _, PayloadParseError e) ->
+      return $ responseLBS status400 [jsonH]
+        (formatGeneralError "Cannot parse request payload" e)
+
+    (ActionInfo, TargetIdent tSchema tTable, _) -> do
+      let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+          pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
           body = encode (TableOptions cols pkeys)
           filterCol :: Schema -> TableName -> Column -> Bool
           filterCol sc tb (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && t==tb
           filterCol _ _ _ =  False
-
       return $ responseLBS status200 [jsonH, allOrigins] $ cs body
 
-    ([table], _) ->
+    (ActionRead, TargetRoot, _) -> do
-      case request of
+      body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure))
-        Left e -> return $ responseLBS status400 [jsonH] $ cs e
+      return $ responseLBS status200 [jsonH] $ cs body
-        Right (selectQuery, Nothing) -> -- should we do sanity check to make sure its a GET request?
-          if range == Just emptyRange
-          then return $ errResponse status416 "HTTP Range error"
-          else do
-            let q = createReadStatement selectQuery (if singular then Nothing else range) singular (not $ hasPrefer "count=none") isCsv
-            row <- H.maybeEx q
-            let (tableTotal, queryTotal, _ , body) = extractQueryResult row
-            if singular
-            then return $ if queryTotal <= 0
-              then responseLBS status404 [] ""
-              else responseLBS status200 [contentTypeH] (fromMaybe "{}" body)
-            else do
-              let frm = fromMaybe 0 $ rangeOffset <$> range
-                  to = frm+queryTotal-1
-                  contentRange = contentRangeH frm to tableTotal
-                  status = rangeStatus frm to tableTotal
-                  canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
-                    . sortBy (comparing fst)
-                    . map (join (***) cs)
-                    . parseSimpleQuery
-                    $ rawQueryString req
-              return $ responseLBS status
-                [contentTypeH, contentRange,
-                  ("Content-Location",
-                    "/" <> cs table <>
-                      if Prelude.null canonical then "" else "?" <> cs canonical
-                  )
-                ] (fromMaybe "[]" body)
-        Right (selectQuery, Just (mutateQuery, isSingle)) ->
-          case verb of
-            "POST"    -> do
-              let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-                  q = createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys isCsv
-              row <- H.maybeEx q
-              let (_, _, location, body) = extractQueryResult row
-              return $ responseLBS status201
-                [
-                  contentTypeH,
-                  (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
-                ]
-                $ if echoRequested then fromMaybe "[]" body else ""
-            "PATCH"   -> do
-              let q = createWriteStatement selectQuery mutateQuery False echoRequested [] isCsv
-              row <- H.maybeEx q
-              let (_, queryTotal, _, body) = extractQueryResult row
-                  r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
-                  s = case () of _ | queryTotal == 0 -> status404
-                                   | echoRequested -> status200
-                                   | otherwise -> status204
-              return $ responseLBS s [contentTypeH, r]
-                $ if echoRequested then fromMaybe "[]" body else ""
-            "DELETE"  -> do
-              let q = createWriteStatement selectQuery mutateQuery False False [] isCsv
-              row <- H.maybeEx q
-              let (_, queryTotal, _, _) = extractQueryResult row
-              return $ if queryTotal == 0
-                then notFound
-                else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
-            _         -> return notFound
 
-    (["rpc", proc], "POST") -> do
+    (ActionInvoke, TargetIdent qi, PayloadJSON payload) -> do
-      let qi = QualifiedIdentifier schema (cs proc)
+      exists <- doesProcExist (qiSchema qi) (qiName qi)
-      exists <- doesProcExist schema proc
       if exists
         then do
           let call = B.Stmt "select " V.empty True <>
-                asJson (callProc qi $ fromMaybe HM.empty (decode reqBody))
+                asJson (callProc qi payload)
+              jwtSecret = configJwtSecret conf
+
           bodyJson :: Maybe (Identity Value) <- H.maybeEx call
-          returnJWT <- doesProcReturnJWT schema proc
+          returnJWT <- doesProcReturnJWT qi
           return $ responseLBS status200 [jsonH]
                  (let body = fromMaybe emptyArray $ runIdentity <$> bodyJson in
                     if returnJWT
@@ -162,37 +118,99 @@ app dbStructure conf reqBody req =
                     else cs $ encode body)
         else return notFound
 
-      -- check that proc exists
+    (ActionRead, TargetIdent qi, _) -> do
-      -- check that arg names are all specified
+      let range = iRange intent
-      -- select * from public.proc(a := "foo"::undefined) where whereT limit limitT
+          singular = iPreferSingular intent
+          selectQuery = requestToQuery schema <$> selectApiRequest
+          q = createReadStatement selectQuery range singular
+                (not $ iPreferCount intent) contentType
+      if range == Just emptyRange
+      then return $ errResponse status416 "HTTP Range error"
+      else do
+        row <- H.maybeEx q
+        let (tableTotal, queryTotal, _ , body) = extractQueryResult row
+        if singular
+        then return $ if queryTotal <= 0
+          then responseLBS status404 [] ""
+          else responseLBS status200 [contentTypeH] (fromMaybe "{}" body)
+        else do
+          let frm = fromMaybe 0 $ rangeOffset <$> range
+              to = frm+queryTotal-1
+              contentRange = contentRangeH frm to tableTotal
+              status = rangeStatus frm to tableTotal
+              canonical = urlEncodeVars -- should this be moved to the dbStructure (location)?
+                . sortBy (comparing fst)
+                . map (join (***) cs)
+                . parseSimpleQuery
+                $ rawQueryString req
+          return $ responseLBS status
+            [contentTypeH, contentRange,
+              ("Content-Location",
+                "/" <> cs (qiName qi) <>
+                  if Prelude.null canonical then "" else "?" <> cs canonical
+              )
+            ] (fromMaybe "[]" body)
+    (ActionCreate, TargetIdent qi, PayloadJSON payload) -> undefined
+    (ActionUpdate, TargetIdent qi, PayloadJSON payload) -> undefined
+    (ActionDelete, TargetIdent qi, _) -> undefined
+    (ActionRead, TargetIdent qi, _) -> undefined
 
-    ([], "GET") -> do -- this should be a GET request only
+    (_, _, _) -> return notFound
-      body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure))
-      return $ responseLBS status200 [jsonH] $ cs body
 
-    (_, _) ->
+ where
-      return notFound
+  notFound = responseLBS status404 [] ""
+  filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
+  allPrKeys = dbPrimaryKeys dbStructure
+  allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
+  --   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?
 
-  where
+
-    notFound = responseLBS status404 [] ""
+
-    allPrKeys = dbPrimaryKeys dbStructure
+  -- case (path, verb) of
-    filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
+  --   ([table], _) ->
-    path          = pathInfo req
+  --     case request of
-    verb          = requestMethod req
+  --       Left e -> return $ responseLBS status400 [jsonH] $ cs e
-    hdrs          = requestHeaders req
+  --       Right (selectQuery, Nothing) -> -- should we do sanity check to make sure its a GET request?
-    lookupHeader  = flip lookup hdrs
+  --       Right (selectQuery, Just (mutateQuery, isSingle)) ->
-    hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs
+  --         case verb of
-    accept        = lookupHeader hAccept
+  --           "POST"    -> do
-    schema        = cs $ configSchema conf
+  --             let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-    jwtSecret     = configJwtSecret conf
+  --                 q = createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys isCsv
-    range         = rangeRequested hdrs
+  --             row <- H.maybeEx q
-    allOrigins    = ("Access-Control-Allow-Origin", "*") :: Header
+  --             let (_, _, location, body) = extractQueryResult row
-    contentType   = fromMaybe "application/json" $ contentTypeForAccept accept
+  --             return $ responseLBS status201
-    isCsv         = contentType == csvMT
+  --               [
-    contentTypeH  = (hContentType, contentType)
+  --                 contentTypeH,
-    echoRequested = hasPrefer "return=representation"
+  --                 (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
-    singular      = hasPrefer "plurality=singular"
+  --               ]
-    request = parseRequest schema (dbRelations dbStructure) (head path) req reqBody --TODO! is head safe?
+  --               $ if echoRequested then fromMaybe "[]" body else ""
+  --           "PATCH"   -> do
+  --             let q = createWriteStatement selectQuery mutateQuery False echoRequested [] isCsv
+  --             row <- H.maybeEx q
+  --             let (_, queryTotal, _, body) = extractQueryResult row
+  --                 r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
+  --                 s = case () of _ | queryTotal == 0 -> status404
+  --                                  | echoRequested -> status200
+  --                                  | otherwise -> status204
+  --             return $ responseLBS s [contentTypeH, r]
+  --               $ if echoRequested then fromMaybe "[]" body else ""
+  --           "DELETE"  -> do
+  --             let q = createWriteStatement selectQuery mutateQuery False False [] isCsv
+  --             row <- H.maybeEx q
+  --             let (_, queryTotal, _, _) = extractQueryResult row
+  --             return $ if queryTotal == 0
+  --               then notFound
+  --               else responseLBS status204 [("Content-Range", "*/"<> cs (show queryTotal))] ""
+  --           _         -> return notFound
+
+  -- where
 
 rangeStatus :: Int -> Int -> Maybe Int -> Status
 rangeStatus _ _ Nothing = status200
@@ -239,19 +257,21 @@ parseCsvCell :: BL.ByteString -> Value
 parseCsvCell s = if s == "NULL" then Null else String $ cs s
 
 formatRelationError :: Text -> Text
-formatRelationError e = cs $ encode $ object [
+formatRelationError e = formatGeneralError
-  "mesage" .= ("could not find foreign keys between these entities"::String),
+  "could not find foreign keys between these entities" e
-  "details" .= e]
 
 formatParserError :: ParseError -> Text
-formatParserError e = cs $ encode $ object [
+formatParserError e = formatGeneralError message details
-  "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)
 
+formatGeneralError :: Text -> Text -> Text
+formatGeneralError message details = cs $ encode $ object [
+  "message" .= message,
+  "details" .= details]
+
 parseRequestBody :: Bool -> RequestBody -> Either Text ([Text],[[Value]])
 parseRequestBody isCsv reqBody = first cs $
   checkStructure =<<
@@ -401,6 +421,11 @@ instance ToJSON TableOptions where
       "columns" .= tblOptcolumns t
     , "pkey"   .= tblOptpkey t ]
 
+createSelectQuery :: [Relation] -> QualifiedIdentifier -> SqlQuery
+createSelectQuery rels qi =
+  requestToQuery schema <$> selectApiRequest
+  undefined
+
 parseRequest :: Schema -> [Relation] -> TableName -> Request -> RequestBody -> Either Text (SqlQuery, Maybe (SqlQuery, Bool))
 parseRequest schema allRels rootTableName httpRequest reqBody =
   if method == "GET"

src/PostgREST/DbStructure.hs

@@ -45,13 +45,13 @@ getDbStructure schema = do
     }
 
 doesProc :: forall c s. B.CxValue c Int =>
-            (Text -> Text -> B.Stmt c) -> Text -> Text -> H.Tx c s Bool
+            (Text -> Text -> B.Stmt c) -> QualifiedIdentifier -> H.Tx c s Bool
-doesProc stmt schema proc = do
+doesProc stmt qi = do
-  row :: Maybe (Identity Int) <- H.maybeEx $ stmt schema proc
+  row :: Maybe (Identity Int) <- H.maybeEx $ stmt (qiSchema qi) (qiName qi)
   return $ isJust row
 
-doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
+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
@@ -60,7 +60,7 @@ doesProcExist = doesProc [H.stmt|
       AND    proname = ?
     |]
 
-doesProcReturnJWT :: Text -> Text -> H.Tx P.Postgres s Bool
+doesProcReturnJWT :: QualifiedIdentifier -> H.Tx P.Postgres s Bool
 doesProcReturnJWT = doesProc [H.stmt|
       SELECT 1
       FROM   pg_catalog.pg_namespace n

src/PostgREST/RequestIntent.hs

@@ -59,6 +59,8 @@ data Intent = Intent {
   , iPreferRepresentation :: Bool
   -- | If client wants first row as raw object
   , iPreferSingular :: Bool
+  -- | Whether the client wants a result count (slower)
+  , iPreferCount :: Bool
   }
 
 -- | Examines HTTP request and translates it into user intent.
@@ -94,12 +96,13 @@ userIntent schema req reqBody =
                          "Content-type not acceptable: " <> accept in
 
   Intent action
-    (rangeRequested hdrs)
+    (if singular then Nothing else rangeRequested hdrs)
     target
     (pickContentType $ lookupHeader "accept")
     reqPayload
     (hasPrefer "return=representation")
-    (hasPrefer "plurality=singular")
+    singular
+    (not $ hasPrefer "count=none")
 
  where
   path            = pathInfo req
@@ -107,6 +110,7 @@ userIntent schema req reqBody =
   hdrs            = requestHeaders req
   lookupHeader    = flip lookup hdrs
   hasPrefer val   = any (\(h,v) -> h == "Prefer" && v == val) hdrs
+  singular        = (hasPrefer "plurality=singular")
 
 
 -- PRIVATE ---------------------------------------------------------------