From c80ab6be0f20ed6b9403660ca3a1bcd67e20cccf Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Thu, 19 Nov 2015 20:45:24 -0800 Subject: [PATCH] WIP: converting App --- src/PostgREST/App.hs | 237 ++++++++++++++++++--------------- src/PostgREST/DbStructure.hs | 12 +- src/PostgREST/RequestIntent.hs | 8 +- 3 files changed, 143 insertions(+), 114 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index cd72a0d66..a9ae15570 100644 --- a/src/PostgREST/App.hs +++ b/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 - ([table], "OPTIONS") -> do - let cols = filter (filterCol schema table) $ dbColumns dbStructure - pkeys = map pkName $ filter (filterPk schema table) allPrKeys + let schema = configSchema conf + intent = userIntent schema req reqBody + -- TODO: blow up for Left values + 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], _) -> - case request of - Left e -> return $ responseLBS status400 [jsonH] $ cs e - 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 + (ActionRead, TargetRoot, _) -> do + body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) + return $ responseLBS status200 [jsonH] $ cs body - (["rpc", proc], "POST") -> do - let qi = QualifiedIdentifier schema (cs proc) - exists <- doesProcExist schema proc + (ActionInvoke, TargetIdent qi, PayloadJSON payload) -> do + exists <- doesProcExist (qiSchema qi) (qiName qi) 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 - -- check that arg names are all specified - -- select * from public.proc(a := "foo"::undefined) where whereT limit limitT + (ActionRead, TargetIdent qi, _) -> do + let range = iRange intent + 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 - body <- encode <$> accessibleTables (filter ((== cs schema) . tableSchema) (dbTables dbStructure)) - return $ responseLBS status200 [jsonH] $ cs body + (_, _, _) -> return notFound - (_, _) -> - return notFound + where + 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 - filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk - path = pathInfo req - verb = requestMethod req - hdrs = requestHeaders req - lookupHeader = flip lookup hdrs - hasPrefer val = any (\(h,v) -> h == "Prefer" && v == val) hdrs - accept = lookupHeader hAccept - schema = cs $ configSchema conf - jwtSecret = configJwtSecret conf - range = rangeRequested hdrs - allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - contentType = fromMaybe "application/json" $ contentTypeForAccept accept - isCsv = contentType == csvMT - contentTypeH = (hContentType, contentType) - echoRequested = hasPrefer "return=representation" - singular = hasPrefer "plurality=singular" - request = parseRequest schema (dbRelations dbStructure) (head path) req reqBody --TODO! is head safe? + + + -- case (path, verb) of + -- ([table], _) -> + -- case request of + -- Left e -> return $ responseLBS status400 [jsonH] $ cs e + -- Right (selectQuery, Nothing) -> -- should we do sanity check to make sure its a GET request? + -- 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 + + -- 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 [ - "mesage" .= ("could not find foreign keys between these entities"::String), - "details" .= e] +formatRelationError e = formatGeneralError + "could not find foreign keys between these entities" e formatParserError :: ParseError -> Text -formatParserError e = cs $ encode $ object [ - "message" .= message, - "details" .= details] +formatParserError e = formatGeneralError message 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" diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 81c96b059..bfe871ae9 100644 --- a/src/PostgREST/DbStructure.hs +++ b/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 -doesProc stmt schema proc = do - row :: Maybe (Identity Int) <- H.maybeEx $ stmt schema proc + (Text -> Text -> B.Stmt c) -> QualifiedIdentifier -> H.Tx c s Bool +doesProc stmt qi = do + row :: Maybe (Identity Int) <- H.maybeEx $ stmt (qiSchema qi) (qiName qi) return $ isJust row -doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool -doesProcExist = doesProc [H.stmt| +doesProcExist :: QualifiedIdentifier -> H.Tx P.Postgres s Bool +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 diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index 326fe05be..702c0bb9c 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/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 ---------------------------------------------------------------