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

@@ -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
 

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
+-- | Enumeration of currently supported response content types
--- route responses and upload payloads
+data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
-data ContentType = ApplicationJSON | TextCSV | OpenAPI deriving Eq
+                 | CTAny | CTOther BS.ByteString deriving Eq
 instance Show ContentType where
-  show ApplicationJSON = "application/json; charset=utf-8"
+  show CTApplicationJSON = "application/json"
-  show TextCSV         = "text/csv; charset=utf-8"
+  show CTTextCSV         = "text/csv"
-  show OpenAPI         = "application/openapi+json; charset=utf-8"
+  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)
+  -- | Content types the client will accept, [CTAny] if no Accept header
-  , iAccepts :: Either BS.ByteString ContentType
+  , 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
+      payload = case decodeContentType
-        Right ApplicationJSON ->
+                     . 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 ->
+        CTOther "application/x-www-form-urlencoded" ->
-          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" ->
           PayloadJSON . UniformObjects . V.singleton . M.fromList
                       . map (cs *** JSON.String . cs) . parseSimpleQuery
                       $ cs reqBody
-        Left accept ->
+        ct ->
-          PayloadParseError $
+          PayloadParseError $ "Content-Type not acceptable: " <> cs (show ct)
-            "Content-type not acceptable: " <> accept
       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
+  Warning: discards MIME parameters
-  Content-Type as a degenerate case).
-
-  For example
-  text/csv -> TextCSV
-  */*      -> ApplicationJSON
-  text/csv, application/json -> TextCSV
-  application/json, text/csv -> ApplicationJSON
 -}
-pickContentType :: Maybe BS.ByteString -> Either BS.ByteString ContentType
+decodeContentType :: BS.ByteString -> ContentType
-pickContentType accept
+decodeContentType ct =
-  | isNothing accept || has ctAll || has ctJson = Right ApplicationJSON
+  case BS.takeWhile (/= BS.c2w ';') ct of
-  | has ctCsv = Right TextCSV
+    "application/json"         -> CTApplicationJSON
-  | has ctOpenAPI = Right OpenAPI
+    "text/csv"                 -> CTTextCSV
-  | otherwise = Left accept'
+    "application/openapi+json" -> CTOpenAPI
- where
+    "*/*"                      -> CTAny
-  ctAll  = "*/*"
+    ct'                        -> CTOther ct'
-  ctCsv  = "text/csv"
-  ctJson = "application/json"
-  ctOpenAPI = "application/openapi+json"
-  Just accept' = accept
-  findInAccept = flip find $ parseHttpAccept accept'
-  has          = isJust . findInAccept . BS.isPrefixOf
 
 type CsvData = V.Vector (M.HashMap T.Text BL.ByteString)
 

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
+              stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
-          let stm = createWriteStatement qi sq mq singular representation [] (contentType == TextCSV) 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
+          let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
-              pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+          return $ responseLBS status200 [allOrigins, acceptH] ""
-              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
 
     (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'
+      let host = configHost conf
-          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
+          encodeApi ti = encodeOpenAPI ti uri'
-          header = if contentType == OpenAPI then openapiH else jsonH
+      serves [CTOpenAPI] (iAccepts apiRequest) $ \_ -> do
-      body <- encodeFn <$> H.query schema accessibleTables
+        body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
-      return $ responseLBS status200 [header] $ toS body
+        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, [], "")

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]

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)
-import           Network.HTTP.Types.Status     (status400, status415)
+import           Network.Wai                   (Application, Response)
-import           Network.Wai                   (Application, Request (..),
-                                                Response, requestHeaders)
 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

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

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

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") ""

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
+  describe "OpenAPI" $ do
-    it "lists views in schema" $
+    it "root path returns a valid openapi spec" $
-      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" $
       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