Per-route content negotiation, and OpenAPI only for root (#693)
* WIP: remove non-openapi root spec * Refactor ContentType Different endpoints will favor one type over another * Permit different Accept headers per endpoint * Lint * Add charset to Content-Type only when used as a header Keep it out of error messages * Accept: */* is last resort, not first * Changelog * makeMimeList consistently * Remove schema description from OPTIONS response
This commit is contained in:
Joe Nelson
@@ -15,9 +15,11 @@ This project adheres to [Semantic Versioning](http://semver.org/).
|
||||
|
||||
### Fixed
|
||||
- Do not apply limit to parent items - @ruslantalpa
|
||||
- Customize content negotiation per route - @begriffs
|
||||
|
||||
### Changed
|
||||
- Use HTTP 400 for raise\_exception - @begriffs
|
||||
- Remove non-OpenAPI schema description - @begriffs
|
||||
|
||||
## [0.3.2.0] - 2016-06-10
|
||||
|
||||
|
||||
+49
-46
@@ -4,9 +4,10 @@ import Prelude
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Internal as BS (c2w)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Csv as CSV
|
||||
import Data.List (find, sortBy)
|
||||
import qualified Data.List as L
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.Set as S
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing,
|
||||
@@ -20,7 +21,7 @@ import qualified Data.Text as T
|
||||
import Text.Read (readMaybe)
|
||||
import qualified Data.Vector as V
|
||||
import Network.HTTP.Base (urlEncodeVars)
|
||||
import Network.HTTP.Types.Header (hAuthorization)
|
||||
import Network.HTTP.Types.Header (hAuthorization, hContentType, Header)
|
||||
import Network.HTTP.Types.URI (parseSimpleQuery)
|
||||
import Network.Wai (Request (..))
|
||||
import Network.Wai.Parse (parseHttpAccept)
|
||||
@@ -45,13 +46,18 @@ data Target = TargetIdent QualifiedIdentifier
|
||||
| TargetUnknown [T.Text]
|
||||
-- | How to return the inserted data
|
||||
data PreferRepresentation = Full | HeadersOnly | None deriving Eq
|
||||
-- | Enumeration of currently supported content types for
|
||||
-- route responses and upload payloads
|
||||
data ContentType = ApplicationJSON | TextCSV | OpenAPI deriving Eq
|
||||
-- | Enumeration of currently supported response content types
|
||||
data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
|
||||
| CTAny | CTOther BS.ByteString deriving Eq
|
||||
instance Show ContentType where
|
||||
show ApplicationJSON = "application/json; charset=utf-8"
|
||||
show TextCSV = "text/csv; charset=utf-8"
|
||||
show OpenAPI = "application/openapi+json; charset=utf-8"
|
||||
show CTApplicationJSON = "application/json"
|
||||
show CTTextCSV = "text/csv"
|
||||
show CTOpenAPI = "application/openapi+json"
|
||||
show CTAny = "*/*"
|
||||
show (CTOther ct) = cs ct
|
||||
|
||||
ctToHeader :: ContentType -> Header
|
||||
ctToHeader ct = (hContentType, cs (show ct) <> "; charset=utf-8")
|
||||
|
||||
{-|
|
||||
Describes what the user wants to do. This data type is a
|
||||
@@ -67,8 +73,8 @@ data ApiRequest = ApiRequest {
|
||||
, iRange :: M.HashMap String NonnegRange
|
||||
-- | The target, be it calling a proc or accessing a table
|
||||
, iTarget :: Target
|
||||
-- | The content type the client most desires (or JSON if undecided)
|
||||
, iAccepts :: Either BS.ByteString ContentType
|
||||
-- | Content types the client will accept, [CTAny] if no Accept header
|
||||
, iAccepts :: [ContentType]
|
||||
-- | Data sent by client and used for mutation actions
|
||||
, iPayload :: Maybe Payload
|
||||
-- | If client wants created items echoed back
|
||||
@@ -113,31 +119,27 @@ userApiRequest schema req reqBody =
|
||||
["rpc", proc] -> TargetProc
|
||||
$ QualifiedIdentifier schema proc
|
||||
other -> TargetUnknown other
|
||||
payload = case pickContentType (lookupHeader "content-type") of
|
||||
Right ApplicationJSON ->
|
||||
payload = case decodeContentType
|
||||
. fromMaybe "application/json"
|
||||
$ lookupHeader "content-type" of
|
||||
CTApplicationJSON ->
|
||||
either (PayloadParseError . cs)
|
||||
(\val -> case ensureUniform (pluralize val) of
|
||||
Nothing -> PayloadParseError "All object keys must match"
|
||||
Just json -> PayloadJSON json)
|
||||
(JSON.eitherDecode reqBody)
|
||||
Right TextCSV ->
|
||||
CTTextCSV ->
|
||||
either (PayloadParseError . cs)
|
||||
(\val -> case ensureUniform (csvToJson val) of
|
||||
Nothing -> PayloadParseError "All lines must have same number of fields"
|
||||
Just json -> PayloadJSON json)
|
||||
(CSV.decodeByName reqBody)
|
||||
Right oa@OpenAPI ->
|
||||
PayloadParseError $ "Content-type not acceptable: " <> cs (show oa)
|
||||
-- This is a Left value because form-urlencoded is not a content
|
||||
-- type which we ever use for responses, only something we handle
|
||||
-- just this once for requests
|
||||
Left "application/x-www-form-urlencoded" ->
|
||||
CTOther "application/x-www-form-urlencoded" ->
|
||||
PayloadJSON . UniformObjects . V.singleton . M.fromList
|
||||
. map (cs *** JSON.String . cs) . parseSimpleQuery
|
||||
$ cs reqBody
|
||||
Left accept ->
|
||||
PayloadParseError $
|
||||
"Content-type not acceptable: " <> accept
|
||||
ct ->
|
||||
PayloadParseError $ "Content-Type not acceptable: " <> cs (show ct)
|
||||
relevantPayload = case action of
|
||||
ActionCreate -> Just payload
|
||||
ActionUpdate -> Just payload
|
||||
@@ -149,7 +151,8 @@ userApiRequest schema req reqBody =
|
||||
, iTarget = target
|
||||
, iRange = M.insert "limit" (rangeIntersection headerRange urlRange) $
|
||||
M.fromList [ (cs k, restrictRange (readMaybe =<< v) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k ]
|
||||
, iAccepts = pickContentType $ lookupHeader "accept"
|
||||
, iAccepts = fromMaybe [CTAny] $
|
||||
map decodeContentType . parseHttpAccept <$> lookupHeader "accept"
|
||||
, iPayload = relevantPayload
|
||||
, iPreferRepresentation = representation
|
||||
, iPreferSingular = singular
|
||||
@@ -158,7 +161,7 @@ userApiRequest schema req reqBody =
|
||||
, iSelect = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
|
||||
, iOrder = [(cs k, fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
|
||||
, iCanonicalQS = urlEncodeVars
|
||||
. sortBy (comparing fst)
|
||||
. L.sortBy (comparing fst)
|
||||
. map (join (***) cs)
|
||||
. parseSimpleQuery
|
||||
$ rawQueryString req
|
||||
@@ -197,32 +200,32 @@ userApiRequest schema req reqBody =
|
||||
(readMaybe =<< join (lookup "limit" qParams))
|
||||
urlOffsetRange
|
||||
|
||||
{-|
|
||||
Find the best match from a list of content types accepted by the
|
||||
client in order of decreasing preference and a list of types
|
||||
producible by the server. If there is no match but the client
|
||||
accepts */* then return the top server pick.
|
||||
-}
|
||||
mutuallyAgreeable :: [ContentType] -> [ContentType] -> Maybe ContentType
|
||||
mutuallyAgreeable sProduces cAccepts =
|
||||
let exact = listToMaybe $ L.intersect cAccepts sProduces in
|
||||
if isNothing exact && CTAny `elem` cAccepts
|
||||
then listToMaybe sProduces
|
||||
else exact
|
||||
|
||||
-- PRIVATE ---------------------------------------------------------------
|
||||
|
||||
{-|
|
||||
Picks a preferred content type from an Accept header (or from
|
||||
Content-Type as a degenerate case).
|
||||
|
||||
For example
|
||||
text/csv -> TextCSV
|
||||
*/* -> ApplicationJSON
|
||||
text/csv, application/json -> TextCSV
|
||||
application/json, text/csv -> ApplicationJSON
|
||||
Warning: discards MIME parameters
|
||||
-}
|
||||
pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType
|
||||
pickContentType accept
|
||||
| isNothing accept || has ctAll || has ctJson = Right ApplicationJSON
|
||||
| has ctCsv = Right TextCSV
|
||||
| has ctOpenAPI = Right OpenAPI
|
||||
| otherwise = Left accept'
|
||||
where
|
||||
ctAll = "*/*"
|
||||
ctCsv = "text/csv"
|
||||
ctJson = "application/json"
|
||||
ctOpenAPI = "application/openapi+json"
|
||||
Just accept' = accept
|
||||
findInAccept = flip find $ parseHttpAccept accept'
|
||||
has = isJust . findInAccept . BS.isPrefixOf
|
||||
decodeContentType :: BS.ByteString -> ContentType
|
||||
decodeContentType ct =
|
||||
case BS.takeWhile (/= BS.c2w ';') ct of
|
||||
"application/json" -> CTApplicationJSON
|
||||
"text/csv" -> CTTextCSV
|
||||
"application/openapi+json" -> CTOpenAPI
|
||||
"*/*" -> CTAny
|
||||
ct' -> CTOther ct'
|
||||
|
||||
type CsvData = V.Vector (M.HashMap T.Text BL.ByteString)
|
||||
|
||||
|
||||
+38
-47
@@ -12,7 +12,7 @@ import Data.IORef (IORef, readIORef)
|
||||
import Data.List (delete, lookup)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Ranged.Ranges (emptyRange)
|
||||
import Data.Text (replace, strip, pack, isInfixOf, dropWhile, drop)
|
||||
import Data.Text (replace, strip, pack, isInfixOf, dropWhile, drop, intercalate)
|
||||
import Data.Tree
|
||||
|
||||
import qualified Hasql.Pool as P
|
||||
@@ -41,7 +41,8 @@ import qualified Data.HashMap.Strict as M
|
||||
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..)
|
||||
, Action(..), Target(..)
|
||||
, PreferRepresentation (..)
|
||||
, userApiRequest)
|
||||
, userApiRequest, mutuallyAgreeable
|
||||
, ctToHeader)
|
||||
import PostgREST.Auth (tokenJWT, jwtClaims, containsRole)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.DbStructure
|
||||
@@ -64,7 +65,7 @@ import PostgREST.OpenAPI
|
||||
|
||||
import Data.Foldable (foldr1)
|
||||
import Data.Function (id)
|
||||
import Protolude hiding (dropWhile, drop, Proxy)
|
||||
import Protolude hiding (dropWhile, drop, intercalate, Proxy)
|
||||
|
||||
postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> Application
|
||||
postgrest conf refDbStructure pool =
|
||||
@@ -93,32 +94,28 @@ transactionMode _ = HT.Write
|
||||
|
||||
app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
|
||||
app dbStructure conf apiRequest =
|
||||
let
|
||||
-- TODO: blow up for Left values (there is a middleware that checks the headers)
|
||||
contentType = either (const ApplicationJSON) id (iAccepts apiRequest)
|
||||
contentTypeH = (hContentType, show contentType) in
|
||||
|
||||
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
|
||||
let singular = iPreferSingular apiRequest
|
||||
stm = createReadStatement q cq singular
|
||||
shouldCount (contentType == TextCSV)
|
||||
shouldCount (contentType == CTTextCSV)
|
||||
respondToRange $ do
|
||||
row <- H.query () stm
|
||||
let (tableTotal, queryTotal, _ , body) = row
|
||||
if singular
|
||||
then return $ if queryTotal <= 0
|
||||
then responseLBS status404 [] ""
|
||||
else responseLBS status200 [contentTypeH] (toS body)
|
||||
else responseLBS status200 [ctToHeader contentType] (toS body)
|
||||
else do
|
||||
let (status, contentRange) = rangeHeader queryTotal tableTotal
|
||||
canonical = iCanonicalQS apiRequest
|
||||
return $ responseLBS status
|
||||
[contentTypeH, contentRange,
|
||||
[ctToHeader contentType, contentRange,
|
||||
("Content-Location",
|
||||
"/" <> toS (qiName qi) <>
|
||||
if Protolude.null canonical then "" else "?" <> toS canonical
|
||||
@@ -127,6 +124,7 @@ app dbStructure conf apiRequest =
|
||||
|
||||
(ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table),
|
||||
Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
|
||||
serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
|
||||
case mutateSqlParts of
|
||||
Left e -> return $ responseLBS status400 [jsonH] $ toS e
|
||||
Right (sq,mq) -> do
|
||||
@@ -139,7 +137,7 @@ app dbStructure conf apiRequest =
|
||||
END $$;
|
||||
|]
|
||||
let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
|
||||
let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload
|
||||
let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload
|
||||
row <- H.query uniform stm
|
||||
let (_, _, fs, body) = extractQueryResult row
|
||||
header =
|
||||
@@ -147,16 +145,16 @@ app dbStructure conf apiRequest =
|
||||
else [(hLocation, "/" <> toS table <> renderLocationFields fs)]
|
||||
|
||||
return $ if iPreferRepresentation apiRequest == Full
|
||||
then responseLBS status201 (contentTypeH : header) (toS body)
|
||||
then responseLBS status201 (ctToHeader contentType : header) (toS body)
|
||||
else responseLBS status201 header ""
|
||||
|
||||
(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
|
||||
let singular = iPreferSingular apiRequest
|
||||
let representation = iPreferRepresentation apiRequest
|
||||
let stm = createWriteStatement qi sq mq singular representation [] (contentType == TextCSV) payload
|
||||
stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
|
||||
row <- H.query uniform stm
|
||||
let (_, queryTotal, _, body) = extractQueryResult row
|
||||
when (singular && queryTotal > 1) $
|
||||
@@ -171,23 +169,24 @@ app dbStructure conf apiRequest =
|
||||
| iPreferRepresentation apiRequest == Full -> status200
|
||||
| otherwise -> status204
|
||||
return $ if iPreferRepresentation apiRequest == Full
|
||||
then responseLBS s [contentTypeH, r] (toS body)
|
||||
then responseLBS s [ctToHeader 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
|
||||
let emptyUniform = UniformObjects V.empty
|
||||
fakeload = PayloadJSON emptyUniform
|
||||
stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) fakeload
|
||||
stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload
|
||||
row <- H.query emptyUniform stm
|
||||
let (_, queryTotal, _, body) = extractQueryResult row
|
||||
r = contentRangeH 1 0 (toInteger <$> Just queryTotal)
|
||||
return $ if queryTotal == 0
|
||||
then notFound
|
||||
else if iPreferRepresentation apiRequest == Full
|
||||
then responseLBS status200 [contentTypeH, r] (toS body)
|
||||
then responseLBS status200 [ctToHeader contentType, r] (toS body)
|
||||
else responseLBS status204 [r] ""
|
||||
|
||||
(ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
|
||||
@@ -195,11 +194,8 @@ app dbStructure conf apiRequest =
|
||||
case mTable of
|
||||
Nothing -> return notFound
|
||||
Just table ->
|
||||
let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
|
||||
pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
|
||||
body = encode (TableOptions cols pkeys)
|
||||
acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
|
||||
return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ toS body
|
||||
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
|
||||
@@ -208,7 +204,7 @@ app dbStructure conf apiRequest =
|
||||
jwtSecret = configJwtSecret conf
|
||||
returnType = lookup (qiName qi) $ dbProcs dbStructure
|
||||
returnsJWT = fromMaybe False $ isInfixOf "jwt_claims" <$> returnType
|
||||
case readSqlParts of
|
||||
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)
|
||||
@@ -221,17 +217,16 @@ app dbStructure conf apiRequest =
|
||||
else toS $ encode body)
|
||||
|
||||
(ActionRead, TargetRoot, Nothing) -> do
|
||||
let encodeApi ti = encodeOpenAPI ti uri'
|
||||
host = configHost conf
|
||||
let host = configHost conf
|
||||
port = toInteger $ configPort conf
|
||||
proxy = pickProxy $ toS <$> configProxyUri conf
|
||||
uri Nothing = ("http", pack host, port, "/")
|
||||
uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
|
||||
uri' = uri proxy
|
||||
encodeFn = if contentType == OpenAPI then encodeApi . toTableInfo else encode
|
||||
header = if contentType == OpenAPI then openapiH else jsonH
|
||||
body <- encodeFn <$> H.query schema accessibleTables
|
||||
return $ responseLBS status200 [header] $ toS body
|
||||
encodeApi ti = encodeOpenAPI ti uri'
|
||||
serves [CTOpenAPI] (iAccepts apiRequest) $ \_ -> do
|
||||
body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
|
||||
return $ responseLBS status200 [openapiH] $ toS body
|
||||
|
||||
(ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""
|
||||
|
||||
@@ -259,6 +254,8 @@ 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
|
||||
shouldCount = iPreferCount apiRequest
|
||||
topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
|
||||
@@ -278,6 +275,17 @@ app dbStructure conf apiRequest =
|
||||
status = rangeStatus lower upper (toInteger <$> tableTotal)
|
||||
in (status, contentRange)
|
||||
|
||||
|
||||
serves :: Monad m => [ContentType] -> [ContentType] ->
|
||||
(ContentType -> m Response) -> m Response
|
||||
serves sProduces cAccepts resp =
|
||||
case mutuallyAgreeable sProduces cAccepts of
|
||||
Nothing -> do
|
||||
let failed = intercalate ", " $ map show cAccepts
|
||||
return $ errResponse status415 $
|
||||
"None of these Content-Types are available: " <> failed
|
||||
Just ct -> resp ct
|
||||
|
||||
splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
||||
splitKeyValue kv = (k, BS.tail v)
|
||||
where (k, v) = BS.break (== '=') kv
|
||||
@@ -305,12 +313,6 @@ contentRangeH lower upper total =
|
||||
totalNotZero = fromMaybe True ((/=) 0 <$> total)
|
||||
fromInRange = lower <= upper
|
||||
|
||||
jsonH :: Header
|
||||
jsonH = (hContentType, "application/json; charset=utf-8")
|
||||
|
||||
openapiH :: Header
|
||||
openapiH = (hContentType, "application/openapi+json; charset=utf-8")
|
||||
|
||||
formatRelationError :: Text -> Text
|
||||
formatRelationError = formatGeneralError
|
||||
"could not find foreign keys between these entities"
|
||||
@@ -471,16 +473,5 @@ toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
|
||||
| Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt}
|
||||
| otherwise = Nothing
|
||||
|
||||
data TableOptions = TableOptions {
|
||||
tblOptcolumns :: [Column]
|
||||
, tblOptpkey :: [Text]
|
||||
}
|
||||
|
||||
instance ToJSON TableOptions where
|
||||
toJSON t = object [
|
||||
"columns" .= tblOptcolumns t
|
||||
, "pkey" .= tblOptpkey t ]
|
||||
|
||||
|
||||
extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
|
||||
extractQueryResult = fromMaybe (Nothing, 0, [], "")
|
||||
|
||||
@@ -10,17 +10,19 @@ import qualified Data.Aeson as JSON
|
||||
import qualified Data.Text as T
|
||||
import qualified Hasql.Pool as P
|
||||
import qualified Hasql.Session as H
|
||||
import Network.HTTP.Types.Header
|
||||
import qualified Network.HTTP.Types.Status as HT
|
||||
import Network.Wai (Response, responseLBS)
|
||||
import PostgREST.ApiRequest (ctToHeader, ContentType(..))
|
||||
|
||||
errResponse :: HT.Status -> Text -> Response
|
||||
errResponse status message = responseLBS status [(hContentType, "application/json")] (toS $ T.concat ["{\"message\":\"",message,"\"}"])
|
||||
errResponse status message = responseLBS status
|
||||
[ctToHeader CTApplicationJSON]
|
||||
(toS $ T.concat ["{\"message\":\"",message,"\"}"])
|
||||
|
||||
pgErrResponse :: Bool -> P.UsageError -> Response
|
||||
pgErrResponse authed e =
|
||||
let status = httpStatus authed e
|
||||
jsonType = (hContentType, "application/json")
|
||||
jsonType = ctToHeader CTApplicationJSON
|
||||
wwwAuth = ("WWW-Authenticate", "Bearer")
|
||||
hdrs = if status == HT.status401
|
||||
then [jsonType, wwwAuth]
|
||||
|
||||
@@ -8,20 +8,17 @@ import qualified Data.HashMap.Strict as M
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Hasql.Transaction as H
|
||||
|
||||
import Network.HTTP.Types.Header (hAccept)
|
||||
import Network.HTTP.Types.Status (status400, status415)
|
||||
import Network.Wai (Application, Request (..),
|
||||
Response, requestHeaders)
|
||||
import Network.HTTP.Types.Status (status400)
|
||||
import Network.Wai (Application, Response)
|
||||
import Network.Wai.Middleware.Cors (cors)
|
||||
import Network.Wai.Middleware.Gzip (def, gzip)
|
||||
import Network.Wai.Middleware.Static (only, staticPolicy)
|
||||
|
||||
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..), pickContentType)
|
||||
import PostgREST.ApiRequest (ApiRequest(..))
|
||||
import PostgREST.Auth (claimsToSQL)
|
||||
import PostgREST.Config (AppConfig (..), corsPolicy)
|
||||
import PostgREST.Error (errResponse)
|
||||
import Data.Text
|
||||
import Data.List (lookup)
|
||||
|
||||
import Protolude hiding (concat, null)
|
||||
|
||||
@@ -39,20 +36,8 @@ runWithClaims conf eClaims app req =
|
||||
anon = String . cs $ configAnonRole conf
|
||||
clientErr = return . errResponse status400
|
||||
|
||||
unsupportedAccept :: Application -> Application
|
||||
unsupportedAccept app req respond =
|
||||
case (isTargetRoot, accept) of
|
||||
(_, Left _) -> unsupportedAcceptRespond
|
||||
(False, Right OpenAPI) -> unsupportedAcceptRespond
|
||||
(_, Right _) -> app req respond
|
||||
where accept = pickContentType $ lookup hAccept $ requestHeaders req
|
||||
path = pathInfo req
|
||||
isTargetRoot = fromMaybe True $ (== "") <$> listToMaybe path
|
||||
unsupportedAcceptRespond = respond $ errResponse status415 "Unsupported Accept header, try: application/json"
|
||||
|
||||
defaultMiddle :: Application -> Application
|
||||
defaultMiddle =
|
||||
gzip def
|
||||
. cors corsPolicy
|
||||
. staticPolicy (only [("favicon.ico", "static/favicon.ico")])
|
||||
. unsupportedAccept
|
||||
|
||||
@@ -182,17 +182,17 @@ makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
|
||||
where
|
||||
tOp = (mempty :: Operation)
|
||||
& tags .~ Set.fromList [tn]
|
||||
& produces ?~ makeMimeList [ApplicationJSON, TextCSV]
|
||||
& produces ?~ makeMimeList [CTApplicationJSON, CTTextCSV]
|
||||
& at 200 ?~ "OK"
|
||||
getOp = tOp
|
||||
& parameters .~ map Inline (makeGetParams cs ++ rs)
|
||||
& at 206 ?~ "Partial Content"
|
||||
postOp = tOp
|
||||
& consumes ?~ makeMimeList [ApplicationJSON, TextCSV]
|
||||
& consumes ?~ makeMimeList [CTApplicationJSON, CTTextCSV]
|
||||
& parameters .~ map Inline (makePostParams tn)
|
||||
& at 201 ?~ "Created"
|
||||
patchOp = tOp
|
||||
& consumes ?~ makeMimeList [ApplicationJSON, TextCSV]
|
||||
& consumes ?~ makeMimeList [CTApplicationJSON, CTTextCSV]
|
||||
& parameters .~ map Inline (makePostParams tn ++ rs)
|
||||
& at 204 ?~ "No Content"
|
||||
deletOp = tOp
|
||||
@@ -209,7 +209,7 @@ makeRootPathItem = ("/", p)
|
||||
where
|
||||
getOp = (mempty :: Operation)
|
||||
& tags .~ Set.fromList ["/"]
|
||||
& produces ?~ makeMimeList [ApplicationJSON, OpenAPI]
|
||||
& produces ?~ makeMimeList [CTOpenAPI]
|
||||
& at 200 ?~ "OK"
|
||||
pr = (mempty :: PathItem) & get ?~ getOp
|
||||
p = pr
|
||||
|
||||
@@ -69,4 +69,4 @@ spec =
|
||||
liftIO $ do
|
||||
simpleHeaders r `shouldSatisfy` matchHeader
|
||||
"Access-Control-Allow-Origin" "\\*"
|
||||
simpleBody r `shouldSatisfy` not . BL.null
|
||||
simpleBody r `shouldSatisfy` BL.null
|
||||
|
||||
@@ -395,6 +395,27 @@ spec = do
|
||||
(acceptHdrs "*/*") ""
|
||||
`shouldRespondWith` 200
|
||||
|
||||
it "*/* should rescue an unknown type" $
|
||||
request methodGet "/simple_pk"
|
||||
(acceptHdrs "text/unknowntype, */*") ""
|
||||
`shouldRespondWith` 200
|
||||
|
||||
it "specific available preference should override */*" $ do
|
||||
r <- request methodGet "/simple_pk"
|
||||
(acceptHdrs "text/csv, */*") ""
|
||||
liftIO $ do
|
||||
let respHeaders = simpleHeaders r
|
||||
respHeaders `shouldSatisfy` matchHeader
|
||||
"Content-Type" "text/csv; charset=utf-8"
|
||||
|
||||
it "honors client preference even when opposite of server preference" $ do
|
||||
r <- request methodGet "/simple_pk"
|
||||
(acceptHdrs "text/csv, application/json") ""
|
||||
liftIO $ do
|
||||
let respHeaders = simpleHeaders r
|
||||
respHeaders `shouldSatisfy` matchHeader
|
||||
"Content-Type" "text/csv; charset=utf-8"
|
||||
|
||||
it "should respond correctly to multiple types in accept header" $
|
||||
request methodGet "/simple_pk"
|
||||
(acceptHdrs "text/unknowntype, text/csv") ""
|
||||
|
||||
@@ -2,7 +2,6 @@ module Feature.StructureSpec where
|
||||
|
||||
import Test.Hspec hiding (pendingWith)
|
||||
import Test.Hspec.Wai
|
||||
import Test.Hspec.Wai.JSON
|
||||
import Network.HTTP.Types
|
||||
|
||||
import SpecHelper
|
||||
@@ -13,385 +12,15 @@ import Network.Wai.Test (SResponse(simpleHeaders))
|
||||
spec :: SpecWith Application
|
||||
spec = do
|
||||
|
||||
describe "GET /" $ do
|
||||
it "lists views in schema" $
|
||||
request methodGet "/" [] ""
|
||||
`shouldRespondWith` [json| [
|
||||
{"schema":"test","name":"Escap3e;","insertable":true}
|
||||
, {"schema":"test","name":"addresses","insertable":true}
|
||||
, {"schema":"test","name":"articleStars","insertable":true}
|
||||
, {"schema":"test","name":"articles","insertable":true}
|
||||
, {"schema":"test","name":"auto_incrementing_pk","insertable":true}
|
||||
, {"schema":"test","name":"clients","insertable":true}
|
||||
, {"schema":"test","name":"comments","insertable":true}
|
||||
, {"schema":"test","name":"complex_items","insertable":true}
|
||||
, {"schema":"test","name":"compound_pk","insertable":true}
|
||||
, {"schema":"test","name":"empty_table","insertable":true}
|
||||
, {"schema":"test","name":"filtered_tasks","insertable":true}
|
||||
, {"schema":"test","name":"ghostBusters","insertable":true}
|
||||
, {"schema":"test","name":"has_count_column","insertable":false}
|
||||
, {"schema":"test","name":"has_fk","insertable":true}
|
||||
, {"schema":"test","name":"insertable_view_with_join","insertable":true}
|
||||
, {"schema":"test","name":"insertonly","insertable":true}
|
||||
, {"schema":"test","name":"items","insertable":true}
|
||||
, {"schema":"test","name":"json","insertable":true}
|
||||
, {"schema":"test","name":"materialized_view","insertable":false}
|
||||
, {"schema":"test","name":"menagerie","insertable":true}
|
||||
, {"schema":"test","name":"no_pk","insertable":true}
|
||||
, {"schema":"test","name":"nullable_integer","insertable":true}
|
||||
, {"schema":"test","name":"orders","insertable":true}
|
||||
, {"schema":"test","name":"projects","insertable":true}
|
||||
, {"schema":"test","name":"projects_view","insertable":true}
|
||||
, {"schema":"test","name":"simple_pk","insertable":true}
|
||||
, {"schema":"test","name":"tasks","insertable":true}
|
||||
, {"schema":"test","name":"tsearch","insertable":true}
|
||||
, {"schema":"test","name":"users","insertable":true}
|
||||
, {"schema":"test","name":"users_projects","insertable":true}
|
||||
, {"schema":"test","name":"users_tasks","insertable":true}
|
||||
, {"schema":"test","name":"withUnique","insertable":true}
|
||||
] |]
|
||||
{matchStatus = 200}
|
||||
|
||||
it "lists only views user has permission to see" $ do
|
||||
let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"
|
||||
|
||||
request methodGet "/" [auth] ""
|
||||
`shouldRespondWith` [json| [
|
||||
{"schema":"test","name":"authors_only","insertable":true}
|
||||
] |]
|
||||
{matchStatus = 200}
|
||||
|
||||
it "returns a valid openapi spec" $
|
||||
describe "OpenAPI" $ do
|
||||
it "root path returns a valid openapi spec" $
|
||||
validateOpenApiResponse [("Accept", "application/openapi+json")]
|
||||
|
||||
it "should respond to openapi request on none root path with 415" $
|
||||
request methodGet "/none_root_path"
|
||||
request methodGet "/items"
|
||||
(acceptHdrs "application/openapi+json") ""
|
||||
`shouldRespondWith` 415
|
||||
|
||||
describe "Table info" $ do
|
||||
it "The structure of complex views is correctly detected" $
|
||||
request methodOptions "/filtered_tasks" [] "" `shouldRespondWith`
|
||||
[json|
|
||||
{
|
||||
"pkey": [
|
||||
"myId"
|
||||
],
|
||||
"columns": [
|
||||
{
|
||||
"references": null,
|
||||
"default": null,
|
||||
"precision": 32,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "myId",
|
||||
"type": "integer",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": true,
|
||||
"position": 1
|
||||
},
|
||||
{
|
||||
"references": null,
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "name",
|
||||
"type": "text",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": true,
|
||||
"position": 2
|
||||
},
|
||||
{
|
||||
"references": {
|
||||
"schema": "test",
|
||||
"column": "id",
|
||||
"table": "projects"
|
||||
},
|
||||
"default": null,
|
||||
"precision": 32,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "projectID",
|
||||
"type": "integer",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": true,
|
||||
"position": 3
|
||||
}
|
||||
]
|
||||
}
|
||||
|]
|
||||
|
||||
it "is available with OPTIONS verb" $
|
||||
request methodOptions "/menagerie" [] "" `shouldRespondWith`
|
||||
[json|
|
||||
{
|
||||
"pkey":["integer"],
|
||||
"columns":[
|
||||
{
|
||||
"default": null,
|
||||
"precision": 32,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "integer",
|
||||
"type": "integer",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": false,
|
||||
"position": 1,
|
||||
"references": null,
|
||||
"default": null
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": 53,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "double",
|
||||
"type": "double precision",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": false,
|
||||
"references": null,
|
||||
"position": 2
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "varchar",
|
||||
"type": "character varying",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": false,
|
||||
"position": 3,
|
||||
"references": null,
|
||||
"default": null
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "boolean",
|
||||
"type": "boolean",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": false,
|
||||
"references": null,
|
||||
"position": 4
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "date",
|
||||
"type": "date",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": false,
|
||||
"references": null,
|
||||
"position": 5
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "money",
|
||||
"type": "money",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": false,
|
||||
"position": 6,
|
||||
"references": null,
|
||||
"default": null
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "enum",
|
||||
"type": "test.enum_menagerie_type",
|
||||
"maxLen": null,
|
||||
"enum": [
|
||||
"foo",
|
||||
"bar"
|
||||
],
|
||||
"nullable": false,
|
||||
"position": 7,
|
||||
"references": null,
|
||||
"default": null
|
||||
}
|
||||
]
|
||||
}
|
||||
|]
|
||||
|
||||
it "it includes primary and foreign keys for views" $
|
||||
request methodOptions "/projects_view" [] "" `shouldRespondWith`
|
||||
[json|
|
||||
{
|
||||
"pkey":[
|
||||
"id"
|
||||
],
|
||||
"columns":[
|
||||
{
|
||||
"references":null,
|
||||
"default":null,
|
||||
"precision":32,
|
||||
"updatable":true,
|
||||
"schema":"test",
|
||||
"name":"id",
|
||||
"type":"integer",
|
||||
"maxLen":null,
|
||||
"enum":[],
|
||||
"nullable":true,
|
||||
"position":1
|
||||
},
|
||||
{
|
||||
"references":null,
|
||||
"default":null,
|
||||
"precision":null,
|
||||
"updatable":true,
|
||||
"schema":"test",
|
||||
"name":"name",
|
||||
"type":"text",
|
||||
"maxLen":null,
|
||||
"enum":[],
|
||||
"nullable":true,
|
||||
"position":2
|
||||
},
|
||||
{
|
||||
"references": {
|
||||
"schema":"test",
|
||||
"column":"id",
|
||||
"table":"clients"
|
||||
},
|
||||
"default":null,
|
||||
"precision":32,
|
||||
"updatable":true,
|
||||
"schema":"test",
|
||||
"name":"client_id",
|
||||
"type":"integer",
|
||||
"maxLen":null,
|
||||
"enum":[],
|
||||
"nullable":true,
|
||||
"position":3
|
||||
}
|
||||
]
|
||||
}
|
||||
|]
|
||||
|
||||
it "includes foreign key data" $
|
||||
request methodOptions "/has_fk" [] ""
|
||||
`shouldRespondWith` [json|
|
||||
{
|
||||
"pkey": ["id"],
|
||||
"columns":[
|
||||
{
|
||||
"default": "nextval('test.has_fk_id_seq'::regclass)",
|
||||
"precision": 64,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "id",
|
||||
"type": "bigint",
|
||||
"maxLen": null,
|
||||
"nullable": false,
|
||||
"position": 1,
|
||||
"enum": [],
|
||||
"references": null
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": 32,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "auto_inc_fk",
|
||||
"type": "integer",
|
||||
"maxLen": null,
|
||||
"nullable": true,
|
||||
"position": 2,
|
||||
"enum": [],
|
||||
"references": {"schema":"test", "table": "auto_incrementing_pk", "column": "id"}
|
||||
}, {
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "simple_fk",
|
||||
"type": "character varying",
|
||||
"maxLen": 255,
|
||||
"nullable": true,
|
||||
"position": 3,
|
||||
"enum": [],
|
||||
"references": {"schema":"test", "table": "simple_pk", "column": "k"}
|
||||
}
|
||||
]
|
||||
}
|
||||
|]
|
||||
|
||||
it "includes all information on views for renamed columns, and raises relations to correct schema" $
|
||||
request methodOptions "/articleStars" [] ""
|
||||
`shouldRespondWith` [json|
|
||||
{
|
||||
"pkey": [
|
||||
"articleId",
|
||||
"userId"
|
||||
],
|
||||
"columns": [
|
||||
{
|
||||
"references": {
|
||||
"schema": "test",
|
||||
"column": "id",
|
||||
"table": "articles"
|
||||
},
|
||||
"default": null,
|
||||
"precision": 32,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "articleId",
|
||||
"type": "integer",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": true,
|
||||
"position": 1
|
||||
},
|
||||
{
|
||||
"references": {
|
||||
"schema": "test",
|
||||
"column": "id",
|
||||
"table": "users"
|
||||
},
|
||||
"default": null,
|
||||
"precision": 32,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "userId",
|
||||
"type": "integer",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": true,
|
||||
"position": 2
|
||||
},
|
||||
{
|
||||
"references": null,
|
||||
"default": null,
|
||||
"precision": null,
|
||||
"updatable": true,
|
||||
"schema": "test",
|
||||
"name": "createdAt",
|
||||
"type": "timestamp without time zone",
|
||||
"maxLen": null,
|
||||
"enum": [],
|
||||
"nullable": true,
|
||||
"position": 3
|
||||
}
|
||||
]
|
||||
}
|
||||
|]
|
||||
|
||||
it "errors for non existant tables" $
|
||||
request methodOptions "/dne" [] "" `shouldRespondWith` 404
|
||||
|
||||
describe "Allow header" $ do
|
||||
|
||||
it "includes read/write verbs for writeable table" $ do
|
||||
|
||||
Reference in New Issue
Block a user