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

Reduce app function (#733)

Browse Source 
Simplify the big app function
This commit is contained in:
Diogo Biazus
2016-11-10 20:42:00 -08:00
committed by Joe Nelson
parent c3822da2d2
commit 41c1cf6e01
6 changed files with 247 additions and 221 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+1
View File
@@ -54,6 +54,7 @@ library
, configurator
, containers
, contravariant
, either
, hasql
, hasql-pool == 0.4.1
, hasql-transaction == 0.4.5.1
src/PostgREST/ApiRequest.hs
+30 -14
View File
@@ -1,4 +1,17 @@
module PostgREST.ApiRequest where
{-|
Module : PostgREST.ApiRequest
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
-}
module PostgREST.ApiRequest ( ApiRequest(..)
, ContentType(..)
, Action(..)
, Target(..)
, PreferRepresentation (..)
, mutuallyAgreeable
, toHeader
, userApiRequest
, toMime
) where
import Protolude
@@ -33,6 +46,7 @@ type RequestBody = BL.ByteString
data Action = ActionCreate | ActionRead
| ActionUpdate | ActionDelete
| ActionInfo | ActionInvoke
| ActionInspect
| ActionInappropriate
deriving Eq
-- | The target db object of a user action
@@ -40,6 +54,7 @@ data Target = TargetIdent QualifiedIdentifier
| TargetProc QualifiedIdentifier
| TargetRoot
| TargetUnknown [Text]
deriving Eq
-- | How to return the inserted data
data PreferRepresentation = Full | HeadersOnly | None deriving Eq
--
@@ -47,15 +62,17 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq
data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
| CTAny | CTOther BS.ByteString deriving Eq
ctToHeader :: ContentType -> Header
ctToHeader ct = (hContentType, toHeader ct <> "; charset=utf-8")
-- | Convert from ContentType to a full HTTP Header
toHeader :: ContentType -> Header
toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
toHeader :: ContentType -> ByteString
toHeader CTApplicationJSON = "application/json"
toHeader CTTextCSV = "text/csv"
toHeader CTOpenAPI = "application/openapi+json"
toHeader CTAny = "*/*"
toHeader (CTOther ct) = ct
-- | Convert from ContentType to a ByteString representing the mime type
toMime :: ContentType -> ByteString
toMime CTApplicationJSON = "application/json"
toMime CTTextCSV = "text/csv"
toMime CTOpenAPI = "application/openapi+json"
toMime CTAny = "*/*"
toMime (CTOther ct) = ct
{-|
Describes what the user wants to do. This data type is a
@@ -104,7 +121,9 @@ userApiRequest schema req reqBody =
else ActionInappropriate
else
case method of
"GET" -> ActionRead
"GET" -> if target == TargetRoot
then ActionInspect
else ActionRead
"POST" -> ActionCreate
"PATCH" -> ActionUpdate
"DELETE" -> ActionDelete
@@ -137,7 +156,7 @@ userApiRequest schema req reqBody =
. map (toS *** JSON.String . toS) . parseSimpleQuery
$ toS reqBody
ct ->
PayloadParseError $ "Content-Type not acceptable: " <> toHeader ct
PayloadParseError $ "Content-Type not acceptable: " <> toMime ct
relevantPayload = case action of
ActionCreate -> Just payload
ActionUpdate -> Just payload
@@ -281,6 +300,3 @@ ensureUniform arr =
if (V.length objs == V.length arr) && areKeysUniform
then Just (UniformObjects objs)
else Nothing
readBSMaybe :: Read a => ByteString -> Maybe a
readBSMaybe = readMaybe . toS
src/PostgREST/App.hs
+80 -71
View File
@@ -15,6 +15,7 @@ import Data.Ranged.Ranges (emptyRange)
import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate)
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Tree
import Data.Either.Combinators (mapLeft)
import qualified Hasql.Pool as P
import qualified Hasql.Transaction as HT
@@ -38,13 +39,14 @@ import qualified Hasql.Transaction as H
import qualified Data.HashMap.Strict as M
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..)
import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..)
, Action(..), Target(..)
, PreferRepresentation (..)
, userApiRequest, mutuallyAgreeable
, ctToHeader
, mutuallyAgreeable
, toHeader
, userApiRequest
, toHeader)
, toMime
)
import PostgREST.Auth (jwtClaims, containsRole)
import PostgREST.Config (AppConfig (..))
import PostgREST.DbStructure
@@ -98,40 +100,39 @@ transactionMode _ = HT.Write
app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
app dbStructure conf apiRequest =
case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
Left errorResponse -> return errorResponse
Right contentType ->
case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
(ActionRead, TargetIdent qi, Nothing) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
case readSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e
Right (q, cq) -> do
Left errorResponse -> return errorResponse
Right (q, cq) -> respondToRange $ do
let singular = iPreferSingular apiRequest
stm = createReadStatement q cq singular
shouldCount (contentType == CTTextCSV)
respondToRange $ do
stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV)
row <- H.query () stm
let (tableTotal, queryTotal, _ , body) = row
if singular
then return $ if queryTotal <= 0
then responseLBS status404 [] ""
else responseLBS status200 [ctToHeader contentType] (toS body)
then notFound
else responseLBS status200 [toHeader contentType] (toS body)
else do
let (status, contentRange) = rangeHeader queryTotal tableTotal
canonical = iCanonicalQS apiRequest
--TargetIdent qi = iTarget apiRequest
return $ responseLBS status
[ctToHeader contentType, contentRange,
[toHeader contentType, contentRange,
("Content-Location",
"/" <> toS (qiName qi) <>
if BS.null canonical then "" else "?" <> toS canonical
)
] (toS body)
(ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table),
Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
(ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e
Right (sq,mq) -> do
Left errorResponse -> return errorResponse
Right (sq, mq) -> do
let isSingle = (==1) $ V.length rows
when (not isSingle && iPreferSingular apiRequest) $
HT.sql [P6.q| DO $$
@@ -149,7 +150,7 @@ app dbStructure conf apiRequest =
then Nothing
else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
, if iPreferRepresentation apiRequest == Full
then Just $ ctToHeader contentType
then Just $ toHeader contentType
else Nothing
, Just . contentRangeH 1 0 $
toInteger <$> if shouldCount then Just (V.length rows) else Nothing
@@ -160,10 +161,9 @@ app dbStructure conf apiRequest =
then toS body else ""
(ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e
Right (sq,mq) -> do
Left errorResponse -> return errorResponse
Right (sq, mq) -> do
let singular = iPreferSingular apiRequest
stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
row <- H.query uniform stm
@@ -181,14 +181,13 @@ app dbStructure conf apiRequest =
| iPreferRepresentation apiRequest == Full -> status200
| otherwise -> status204
return $ if iPreferRepresentation apiRequest == Full
then responseLBS s [ctToHeader contentType, r] (toS body)
then responseLBS s [toHeader contentType, r] (toS body)
else responseLBS s [r] ""
(ActionDelete, TargetIdent qi, Nothing) ->
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
case mutateSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e
Right (sq,mq) -> do
Left errorResponse -> return errorResponse
Right (sq, mq) -> do
let emptyUniform = UniformObjects V.empty
fakeload = PayloadJSON emptyUniform
stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload
@@ -199,7 +198,7 @@ app dbStructure conf apiRequest =
return $ if queryTotal == 0
then notFound
else if iPreferRepresentation apiRequest == Full
then responseLBS status200 [ctToHeader contentType, r] (toS body)
then responseLBS status200 [toHeader contentType, r] (toS body)
else responseLBS status204 [r] ""
(ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
@@ -210,20 +209,19 @@ app dbStructure conf apiRequest =
let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
return $ responseLBS status200 [allOrigins, acceptH] ""
(ActionInvoke, TargetProc qi,
Just (PayloadJSON (UniformObjects payload))) -> do
(ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) ->
case readSqlParts of
Left errorResponse -> return errorResponse
Right (q, cq) -> respondToRange $ do
let p = V.head payload
singular = iPreferSingular apiRequest
serves [CTApplicationJSON] (iAccepts apiRequest) $ \_ -> case readSqlParts of
Left e -> return $ responseLBS status400 [jsonH] $ toS e
Right (q,cq) -> respondToRange $ do
row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular)
let (tableTotal, queryTotal, body) =
fromMaybe (Just 0, 0, emptyArray) row
(status, contentRange) = rangeHeader queryTotal tableTotal
return $ responseLBS status [jsonH, contentRange] (toS . encode $ body)
(ActionRead, TargetRoot, Nothing) -> do
(ActionInspect, TargetRoot, Nothing) -> do
let host = configHost conf
port = toInteger $ configPort conf
proxy = pickProxy $ toS <$> configProxyUri conf
@@ -231,19 +229,14 @@ app dbStructure conf apiRequest =
uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
uri' = uri proxy
encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri'
serves [CTOpenAPI] (iAccepts apiRequest) $ \_ -> do
body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
return $ responseLBS status200 [openapiH] $ toS body
(ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""
return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
(_, _, Just (PayloadParseError e)) ->
return $ responseLBS status400 [jsonH] $
return $ errResponse status400 $
toS (formatGeneralError "Cannot parse request payload" (toS e))
(_, TargetUnknown _, _) -> return notFound
(_, _, _) -> return notFound
_ -> return notFound
where
toTableInfo :: [Table] -> [(Table, [Column], [Text])]
@@ -252,8 +245,7 @@ app dbStructure conf apiRequest =
tTable = tableName t
cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
in
(t, cols, pkeys))
in (t, cols, pkeys))
notFound = responseLBS status404 [] ""
filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
filterCol :: Schema -> TableName -> Column -> Bool
@@ -261,38 +253,53 @@ app dbStructure conf apiRequest =
filterCol _ _ _ = False
allPrKeys = dbPrimaryKeys dbStructure
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
jsonH = ctToHeader CTApplicationJSON
openapiH = ctToHeader CTOpenAPI
schema = toS $ configSchema conf
jsonH = toHeader CTApplicationJSON
shouldCount = iPreferCount apiRequest
schema = toS $ configSchema conf
topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
mapSnd f (a, b) = (a, f b)
readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest
selectQuery = requestToQuery schema False <$> readDbRequest
countQuery = requestToCountQuery schema <$> readDbRequest
mutateQuery = requestToQuery schema False <$> mutateDbRequest
readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
respondToRange response = if topLevelRange == emptyRange
then return $ errResponse status416 "HTTP Range error"
else response
rangeHeader queryTotal tableTotal = let lower = rangeOffset topLevelRange
rangeHeader queryTotal tableTotal =
let lower = rangeOffset topLevelRange
upper = lower + toInteger queryTotal - 1
contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
status = rangeStatus lower upper (toInteger <$> tableTotal)
in (status, contentRange)
mapSnd f (a, b) = (a, f b)
readDbRequest = DbRead <$> readRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
mutateDbRequest = DbMutate <$> mutateRequest apiRequest
selectQuery = requestToQuery schema False <$> readDbRequest
mutateQuery = requestToQuery schema False <$> mutateDbRequest
countQuery = requestToCountQuery schema <$> readDbRequest
readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
respondToRange response =
if topLevelRange == emptyRange
then return $ errResponse status416 "HTTP Range error"
else response
serves :: Monad m => [ContentType] -> [ContentType] ->
(ContentType -> m Response) -> m Response
serves sProduces cAccepts resp =
responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
responseContentTypeOrError accepts action =
case action of
ActionInappropriate -> Left $ errResponse status405 "Unsupported HTTP verb"
_ -> serves contentTypesForRequest accepts
where
contentTypesForRequest =
case action of
ActionRead -> [CTApplicationJSON, CTTextCSV]
ActionCreate -> [CTApplicationJSON, CTTextCSV]
ActionUpdate -> [CTApplicationJSON, CTTextCSV]
ActionDelete -> [CTApplicationJSON, CTTextCSV]
ActionInvoke -> [CTApplicationJSON]
ActionInspect -> [CTOpenAPI]
ActionInfo -> [CTTextCSV]
ActionInappropriate -> []
serves sProduces cAccepts =
case mutuallyAgreeable sProduces cAccepts of
Nothing -> do
let failed = intercalate ", " $ map (toS . toHeader) cAccepts
return $ errResponse status415 $
let failed = intercalate ", " $ map (toS . toMime) cAccepts
Left $ errResponse status415 $
"None of these Content-Types are available: " <> failed
Just ct -> resp ct
Just ct -> Right ct
splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
splitKeyValue kv = (k, BS.tail v)
@@ -372,11 +379,12 @@ treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` re
nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)
buildReadRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Text ReadRequest
buildReadRequest maxRows allRels allProcs apiRequest =
readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest
readRequest maxRows allRels allProcs apiRequest =
mapLeft (errResponse status400) $
treeRestrictRange maxRows =<<
augumentRequestWithJoin schema relations =<<
first formatParserError readRequest
first formatParserError parseReadRequest
where
(schema, rootTableName) = fromJust $ -- Make it safe
let target = iTarget apiRequest in
@@ -395,8 +403,8 @@ buildReadRequest maxRows allRels allProcs apiRequest =
action :: Action
action = iAction apiRequest
readRequest :: Either ParseError ReadRequest
readRequest = addFiltersOrdersRanges apiRequest <*>
parseReadRequest :: Either ParseError ReadRequest
parseReadRequest = addFiltersOrdersRanges apiRequest <*>
parse (pRequestSelect rootName) ("failed to parse select parameter <<" <> toS selStr <> ">>") (toS selStr)
where
selStr = iSelect apiRequest
@@ -413,8 +421,9 @@ buildReadRequest maxRows allRels allProcs apiRequest =
_ -> allRels
where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
buildMutateRequest :: ApiRequest -> Either Text MutateRequest
buildMutateRequest apiRequest = case action of
mutateRequest :: ApiRequest -> Either Response MutateRequest
mutateRequest apiRequest = mapLeft (errResponse status400) $
case action of
ActionCreate -> Insert rootTableName <$> pure payload
ActionUpdate -> Update rootTableName <$> pure payload <*> filters
ActionDelete -> Delete rootTableName <$> filters
src/PostgREST/Error.hs
+3 -3
View File
@@ -12,17 +12,17 @@ import qualified Hasql.Pool as P
import qualified Hasql.Session as H
import qualified Network.HTTP.Types.Status as HT
import Network.Wai (Response, responseLBS)
import PostgREST.ApiRequest (ctToHeader, ContentType(..))
import PostgREST.ApiRequest (toHeader, ContentType(..))
errResponse :: HT.Status -> Text -> Response
errResponse status message = responseLBS status
[ctToHeader CTApplicationJSON]
[toHeader CTApplicationJSON]
(toS $ T.concat ["{\"message\":\"",message,"\"}"])
pgErrResponse :: Bool -> P.UsageError -> Response
pgErrResponse authed e =
let status = httpStatus authed e
jsonType = ctToHeader CTApplicationJSON
jsonType = toHeader CTApplicationJSON
wwwAuth = ("WWW-Authenticate", "Bearer")
hdrs = if status == HT.status401
then [jsonType, wwwAuth]
src/PostgREST/Middleware.hs
+2 -2
View File
@@ -15,7 +15,7 @@ import Network.Wai.Middleware.Gzip (def, gzip)
import Network.Wai.Middleware.Static (only, staticPolicy)
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..),
ctToHeader)
toHeader)
import PostgREST.Auth (claimsToSQL, JWTAttempt(..))
import PostgREST.Config (AppConfig (..), corsPolicy)
import PostgREST.Error (errResponse)
@@ -40,7 +40,7 @@ runWithClaims conf eClaims app req =
anon = String . toS $ configAnonRole conf
customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
unauthed message = responseLBS unauthorized401
[ ctToHeader CTApplicationJSON
[ toHeader CTApplicationJSON
, ( "WWW-Authenticate"
, "Bearer error=\"invalid_token\", " <>
"error_description=\"" <> message <> "\""
src/PostgREST/OpenAPI.hs
+2 -2
View File
@@ -20,14 +20,14 @@ import Protolude hiding (concat, (&), Proxy, get, interca
import Data.Swagger
import PostgREST.ApiRequest (ContentType(..), toHeader)
import PostgREST.ApiRequest (ContentType(..), toMime)
import PostgREST.Config (prettyVersion)
import PostgREST.QueryBuilder (operators)
import PostgREST.Types (Table(..), Column(..), PgArg(..),
Proxy(..), ProcDescription(..))
makeMimeList :: [ContentType] -> MimeList
makeMimeList cs = MimeList $ map (fromString . toS . toHeader) cs
makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
toSwaggerType :: Text -> SwaggerType t
toSwaggerType "text" = SwaggerString