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
+36 -125
View File
@@ -14,14 +14,12 @@ module PostgREST.App where
-- , bb
-- ) where
import qualified Blaze.ByteString.Builder as BB
import Control.Applicative
import Control.Arrow ((***))
import Control.Monad (join)
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (original)
import qualified Data.Csv as CSV
import Data.Functor.Identity
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.URI (parseSimpleQuery)
import Network.Wai
--import Network.Wai.Internal
import Network.Wai.Internal (Response (..))
import Network.Wai.Parse (parseHttpAccept)
import Data.Aeson
@@ -88,31 +84,17 @@ app dbstructure conf reqBody req =
case query of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
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
(withSourceF qs <>
" SELECT " <>
(if hasPrefer "count=none" then countNoneF else countAllF) <>
"," <>
countF <>
"," <>
(case contentType of
"text/csv" -> asCsvF
_ -> asJsonF
) <>
" " <>
fromF ( limitF range ))
(
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
)
] range
)
V.empty True
row <- H.maybeEx q
let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
@@ -134,37 +116,34 @@ app dbstructure conf reqBody req =
where
frm = fromMaybe 0 $ rangeOffset <$> range
apiRequest = first formatParserError (parseGetRequest req)
apiRequest = first formatParserError (parseGetRequest table req)
>>= first formatRelationError . addRelations schema allRels Nothing
>>= addJoinConditions schema allCols
query = requestToQuery schema <$> apiRequest
--countQuery = requestToCountQuery schema <$> apiRequest
--queries = (,) <$> query <*> countQuery
([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
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right qs -> do
let isSingle = either (const False) id returnSingle
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
q = B.Stmt
(withSourceF qs <>
" SELECT " <>
(if isSingle then locationF pKeys else "null") <>
"," <>
countF <>
"," <>
(case contentType of
"text/csv" -> asCsvF
_ -> if isSingle then asJsonSingleF else asJsonF
) <>
" " <>
fromF ( limitF Nothing ))
V.empty True
(
wrapQuery qs [
(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"
)
] 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
@@ -176,61 +155,12 @@ app dbstructure conf reqBody req =
(hLocation, "/" <> cs table <> "?" <> cs locationH)
]
$ 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
res = parsePostRequest req reqBody
res = parsePostRequest table req reqBody
apiRequest = snd <$> res
returnSingle = fst <$> res
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
let qi = QualifiedIdentifier schema (cs proc)
exists <- doesProcExist schema proc
@@ -408,25 +338,6 @@ handleJsonObj reqBody handler = do
parseCsvCell :: BL.ByteString -> Value
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 e = cs $ encode $ object [
"mesage" .= ("could not find foreign keys between these entities"::String),
@@ -439,9 +350,9 @@ formatParserError e = cs $ encode $ object [
message = show (errorPos e)
details = strip $ replace "\n" " " $ cs
$ 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 httpRequest reqBody =
parsePostRequest :: NodeName -> Request -> BL.ByteString -> Either Text (Bool, ApiRequest)
parsePostRequest rootTableName httpRequest reqBody =
(,) <$> returnSingle <*> node
where
node = Node <$> apiNode <*> pure []
@@ -471,10 +382,10 @@ parsePostRequest httpRequest reqBody =
-- Object _ -> Right True
-- _ -> 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
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
headerMatchesContent :: ([Text], [[Value]]) -> Bool
@@ -510,14 +421,14 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
a@(Array _) -> Right a
_ -> Left invalidMsg
parseGetRequest :: Request -> Either ParseError ApiRequest
parseGetRequest httpRequest =
parseGetRequest :: NodeName -> Request -> Either ParseError ApiRequest
parseGetRequest rootTableName httpRequest =
foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts
where
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select parameter <<"++selectStr++">>") $ cs selectStr
addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
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]
orderStr = join $ lookup "order" qString
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 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 s = "WITH source AS (" <> s <>")"
@@ -378,7 +385,6 @@ locationF :: [T.Text] -> T.Text
locationF pKeys =
"(" <>
" 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'), '&')" <>
" FROM s, json_each_text(s.r) AS json_data" <>
(