jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

code cleanup

Browse Source
This commit is contained in:
Ruslan Talpa
2015-10-23 10:13:51 +03:00
parent 21bd921ee7
commit d4a8716a0e
2 changed files with 43 additions and 126 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+31 -120
View File
@@ -14,14 +14,12 @@ module PostgREST.App where
-- , bb -- , bb
-- ) where -- ) where
import qualified Blaze.ByteString.Builder as BB
import Control.Applicative import Control.Applicative
import Control.Arrow ((***)) import Control.Arrow ((***))
import Control.Monad (join) import Control.Monad (join)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (original)
import qualified Data.Csv as CSV import qualified Data.Csv as CSV
import Data.Functor.Identity import Data.Functor.Identity
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
@@ -43,8 +41,6 @@ import Network.HTTP.Types.Header
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
import Network.HTTP.Types.URI (parseSimpleQuery) import Network.HTTP.Types.URI (parseSimpleQuery)
import Network.Wai import Network.Wai
--import Network.Wai.Internal
import Network.Wai.Internal (Response (..))
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import Data.Aeson import Data.Aeson
@@ -88,31 +84,17 @@ app dbstructure conf reqBody req =
case query of case query of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right qs -> do Right qs -> do
-- let qt = qualify table
-- count = if hasPrefer "count=none"
-- then countNone
-- else cqs
-- q = B.Stmt "select " V.empty True <>
-- parentheticT count
-- <> commaq <> (
-- bodyForAccept contentType qt -- TODO! when in csv mode, the first row (columns) is not correct when requesting sub tables
-- . limitT range
-- $ qs
-- )
let q = B.Stmt let q = B.Stmt
(withSourceF qs <> (
" SELECT " <> wrapQuery qs [
(if hasPrefer "count=none" then countNoneF else countAllF) <> (if hasPrefer "count=none" then countNoneF else countAllF),
"," <> countF,
countF <>
"," <>
(case contentType of (case contentType of
"text/csv" -> asCsvF "text/csv" -> asCsvF -- TODO check when in csv mode if the header is correct when requesting nested data
_ -> asJsonF _ -> asJsonF
) <> )
" " <> ] range
fromF ( limitF range )) )
V.empty True V.empty True
row <- H.maybeEx q 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) row
@@ -134,36 +116,33 @@ app dbstructure conf reqBody req =
where where
frm = fromMaybe 0 $ rangeOffset <$> range frm = fromMaybe 0 $ rangeOffset <$> range
apiRequest = first formatParserError (parseGetRequest req) apiRequest = first formatParserError (parseGetRequest table req)
>>= first formatRelationError . addRelations schema allRels Nothing >>= first formatRelationError . addRelations schema allRels Nothing
>>= addJoinConditions schema allCols >>= addJoinConditions schema allCols
query = requestToQuery schema <$> apiRequest query = requestToQuery schema <$> apiRequest
--countQuery = requestToCountQuery schema <$> apiRequest
--queries = (,) <$> query <*> countQuery
([table], "POST") -> do ([table], "POST") -> do
let echoRequested = hasPrefer "return=representation" --TODO!! do not request content at all in query if not echoRequested let echoRequested = hasPrefer "return=representation"
case insertQuery of case insertQuery of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right qs -> do Right qs -> do
let isSingle = either (const False) id returnSingle let isSingle = either (const False) id returnSingle
pKeys = map pkName $ filter (filterPk schema table) allPrKeys pKeys = map pkName $ filter (filterPk schema table) allPrKeys
q = B.Stmt q = B.Stmt
(withSourceF qs <> (
" SELECT " <> wrapQuery qs [
(if isSingle then locationF pKeys else "null") <> (if isSingle then locationF pKeys else "null"),
"," <> "null", -- countF,
countF <> (
"," <> if echoRequested
(case contentType of then
case contentType of
"text/csv" -> asCsvF "text/csv" -> asCsvF
_ -> if isSingle then asJsonSingleF else asJsonF _ -> if isSingle then asJsonSingleF else asJsonF
) <> else "null"
" " <> )
fromF ( limitF Nothing )) ] Nothing
)
V.empty True V.empty True
row <- H.maybeEx q row <- H.maybeEx q
@@ -176,61 +155,12 @@ app dbstructure conf reqBody req =
(hLocation, "/" <> cs table <> "?" <> cs locationH) (hLocation, "/" <> cs table <> "?" <> cs locationH)
] ]
$ if echoRequested then body else "" $ if echoRequested then body else ""
-- let qt = qualify table
-- echoRequested = hasPrefer "return=representation"
-- parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
-- parsed = if lookupHeader "Content-Type" == Just csvMT
-- then do
-- rows <- CSV.decode CSV.NoHeader reqBody
-- if V.null rows then Left "CSV requires header"
-- else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
-- else eitherDecode reqBody >>= \val ->
-- case val of
-- Object obj -> Right . second V.singleton . V.unzip . V.fromList $
-- M.toList obj
-- _ -> Left "Expecting single JSON object or CSV rows"
-- case parsed of
-- Left err -> return $ responseLBS status400 [] $
-- encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
-- Right toBeInserted -> do
-- rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
-- let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
-- pKeys = map pkName $ filter (filterPk schema table) allPrKeys
-- responses = flip map inserted $ \obj -> do
-- let primaries =
-- if Prelude.null pKeys
-- then obj
-- else M.filterWithKey (const . (`elem` pKeys)) obj
-- let params = urlEncodeVars
-- $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
-- $ sortBy (comparing fst) $ M.toList primaries
-- responseLBS status201
-- [ jsonH
-- , (hLocation, "/" <> cs table <> "?" <> cs params)
-- ] $ if echoRequested then encode obj else ""
-- return $ multipart status201 responses
where where
res = parsePostRequest req reqBody res = parsePostRequest table req reqBody
apiRequest = snd <$> res apiRequest = snd <$> res
returnSingle = fst <$> res returnSingle = fst <$> res
insertQuery = requestToQuery schema <$> apiRequest insertQuery = requestToQuery schema <$> apiRequest
-- localWithT (B.Stmt eq ep epre) v (B.Stmt wq wp wpre) =
-- B.Stmt ("WITH " <> v <> " AS (" <> eq <> ") " <> wq)
-- (ep <> wp)
-- (epre && wpre)
--
-- query = localWithT
-- <$> insertQuery
-- <*> pure "k"
-- <*> pure (
-- B.Stmt "SELECT " V.empty True <>
-- bodyForAccept contentType (QualifiedIdentifier "" "k") (B.Stmt "SELECT * FROM k" V.empty True)
-- )
-- -- TODO! csv does not work because k is not a real table
(["rpc", proc], "POST") -> do (["rpc", proc], "POST") -> do
let qi = QualifiedIdentifier schema (cs proc) let qi = QualifiedIdentifier schema (cs proc)
exists <- doesProcExist schema proc exists <- doesProcExist schema proc
@@ -408,25 +338,6 @@ handleJsonObj reqBody handler = do
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
multipart :: Status -> [Response] -> Response
multipart _ [] = responseLBS status204 [] ""
multipart _ [r] = r
multipart s rs =
responseLBS s [(hContentType, "multipart/mixed; boundary=\"postgrest_boundary\"")] $
BL.intercalate "\n--postgrest_boundary\n" (map renderResponseBody rs)
where
renderHeader :: Header -> BL.ByteString
renderHeader (k, v) = cs (original k) <> ": " <> cs v
renderResponseBody :: Response -> BL.ByteString
renderResponseBody (ResponseBuilder _ headers b) =
BL.intercalate "\n" (map renderHeader headers)
<> "\n\n" <> BB.toLazyByteString b
renderResponseBody _ = error
"Unable to create multipart response from non-ResponseBuilder"
formatRelationError :: Text -> Text formatRelationError :: Text -> Text
formatRelationError e = cs $ encode $ object [ formatRelationError e = cs $ encode $ object [
"mesage" .= ("could not find foreign keys between these entities"::String), "mesage" .= ("could not find foreign keys between these entities"::String),
@@ -439,9 +350,9 @@ formatParserError e = cs $ encode $ object [
message = show (errorPos e) message = show (errorPos e)
details = strip $ replace "\n" " " $ cs details = strip $ replace "\n" " " $ cs
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e) $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
--parsePostRequest :: Request -> BL.ByteString -> Either String (V.Vector Text, V.Vector (V.Vector Value))
parsePostRequest :: Request -> BL.ByteString -> Either Text (Bool, ApiRequest) parsePostRequest :: NodeName -> Request -> BL.ByteString -> Either Text (Bool, ApiRequest)
parsePostRequest httpRequest reqBody = parsePostRequest rootTableName httpRequest reqBody =
(,) <$> returnSingle <*> node (,) <$> returnSingle <*> node
where where
node = Node <$> apiNode <*> pure [] node = Node <$> apiNode <*> pure []
@@ -471,10 +382,10 @@ parsePostRequest httpRequest reqBody =
-- Object _ -> Right True -- Object _ -> Right True
-- _ -> Right False -- _ -> Right False
-- ) -- )
returnSingle = (==1) . length . snd <$> parsed returnSingle = (==1) . length . snd <$> parsed -- not quite correct qhen the user send single row but in an array
hdrs = requestHeaders httpRequest hdrs = requestHeaders httpRequest
lookupHeader = flip lookup hdrs lookupHeader = flip lookup hdrs
rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
isCsv = lookupHeader "Content-Type" == Just csvMT isCsv = lookupHeader "Content-Type" == Just csvMT
headerMatchesContent :: ([Text], [[Value]]) -> Bool headerMatchesContent :: ([Text], [[Value]]) -> Bool
@@ -510,14 +421,14 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
a@(Array _) -> Right a a@(Array _) -> Right a
_ -> Left invalidMsg _ -> Left invalidMsg
parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest :: NodeName -> Request -> Either ParseError ApiRequest
parseGetRequest httpRequest = parseGetRequest rootTableName httpRequest =
foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
where where
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
addOrder (Node (q,i) f) o = Node (q{order=o}, i) f addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
flts = mapM pRequestFilter whereFilters flts = mapM pRequestFilter whereFilters
rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
orderStr = join $ lookup "order" qString orderStr = join $ lookup "order" qString
ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderStr++">>")) orderStr
src/PostgREST/PgQuery.hs
+7 -1
View File
@@ -329,6 +329,13 @@ paramFilter :: JSON.Value -> T.Text
paramFilter JSON.Null = "is.null" paramFilter JSON.Null = "is.null"
paramFilter v = "eq." <> unquoted v paramFilter v = "eq." <> unquoted v
wrapQuery :: T.Text -> [T.Text] -> Maybe NonnegRange -> T.Text
wrapQuery source selectColumns range =
withSourceF source <>
" SELECT " <>
T.intercalate ", " selectColumns <>
" " <>
fromF ( limitF range )
withSourceF :: T.Text -> T.Text withSourceF :: T.Text -> T.Text
withSourceF s = "WITH source AS (" <> s <>")" withSourceF s = "WITH source AS (" <> s <>")"
@@ -378,7 +385,6 @@ locationF :: [T.Text] -> T.Text
locationF pKeys = locationF pKeys =
"(" <> "(" <>
" WITH s AS (SELECT row_to_json(source) as r from source limit 1)" <> " WITH s AS (SELECT row_to_json(source) as r from source limit 1)" <>
-- " SELECT string_agg(json_data.key || '=eq.' || json_data.value, '&')" <>
" SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <> " SELECT string_agg(json_data.key || '=' || coalesce( 'eq.' || json_data.value, 'is.null'), '&')" <>
" FROM s, json_each_text(s.r) AS json_data" <> " FROM s, json_each_text(s.r) AS json_data" <>
( (