From 1d5a0e43161e75aa7d3078f59c187b1e5db92620 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Fri, 19 Aug 2016 16:07:22 -0700 Subject: [PATCH] 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 --- CHANGELOG.md | 2 + src/PostgREST/ApiRequest.hs | 95 ++++----- src/PostgREST/App.hs | 85 ++++---- src/PostgREST/Error.hs | 8 +- src/PostgREST/Middleware.hs | 21 +- src/PostgREST/OpenAPI.hs | 8 +- test/Feature/CorsSpec.hs | 2 +- test/Feature/QuerySpec.hs | 21 ++ test/Feature/StructureSpec.hs | 377 +--------------------------------- 9 files changed, 126 insertions(+), 493 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 25cb70188..02476bbe8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index b751b7e0e..f8d34210e 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -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) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 890a951d5..baa9c3103 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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, [], "") diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index a93c11802..022b61458 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -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] diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index be05a601d..78e0595a6 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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 diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs index b1d92ee28..c3d75ccd2 100644 --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -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 diff --git a/test/Feature/CorsSpec.hs b/test/Feature/CorsSpec.hs index c639f7309..81564d277 100644 --- a/test/Feature/CorsSpec.hs +++ b/test/Feature/CorsSpec.hs @@ -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 diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 89b7643d9..371076093 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -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") "" diff --git a/test/Feature/StructureSpec.hs b/test/Feature/StructureSpec.hs index 511bbb1bf..1fc60a0df 100644 --- a/test/Feature/StructureSpec.hs +++ b/test/Feature/StructureSpec.hs @@ -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