Introduce the OpenAPI header

Also bring back the original behavior of GET "/"

postgrest.cabal

@@ -66,7 +66,6 @@ executable postgrest
                      , wai-middleware-static >= 0.6.0
                      , warp >= 3.1.0
                      , insert-ordered-containers >= 0.1.0.1
-                     , http-media >= 0.6.3
                      , swagger2 >= 2.1
                      , HTTP
                      , Ranged-sets
@@ -113,7 +112,6 @@ library
                      , wai-middleware-static >= 0.6.0
                      , warp >= 3.1.0
                      , insert-ordered-containers >= 0.1.0.1
-                     , http-media >= 0.6.3
                      , swagger2 >= 2.1
 
   Other-Modules:       Paths_postgrest
@@ -194,7 +192,6 @@ Test-Suite spec
                      , wai-middleware-static
                      , warp
                      , insert-ordered-containers
-                     , http-media
                      , swagger2
                      , HTTP
                      , Ranged-sets

src/PostgREST/ApiRequest.hs

@@ -45,10 +45,11 @@ data Target = TargetIdent QualifiedIdentifier
 data PreferRepresentation = Full | HeadersOnly | None deriving Eq
 -- | Enumeration of currently supported content types for
 -- route responses and upload payloads
-data ContentType = ApplicationJSON | TextCSV deriving Eq
+data ContentType = ApplicationJSON | TextCSV | OpenAPI 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"
 
 {-|
   Describes what the user wants to do. This data type is a
@@ -123,6 +124,8 @@ userApiRequest schema req reqBody =
               Nothing -> PayloadParseError "All lines must have same number of fields"
               Just json -> PayloadJSON json)
             (CSV.decodeByName reqBody)
+        Right OpenAPI ->
+          PayloadParseError "Content-type not acceptable"
         -- 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
@@ -208,11 +211,13 @@ 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

src/PostgREST/App.hs

@@ -204,7 +204,9 @@ app dbStructure conf apiRequest =
         else return notFound
 
     (ActionRead, TargetRoot, Nothing) -> do
-      body <- (encodeApi . toTableInfo) <$> H.query schema accessibleTables
+      body <- if contentType == OpenAPI
+                 then (encodeApi . toTableInfo) <$> H.query schema accessibleTables
+                 else encode <$> H.query schema accessibleTables
       return $ responseLBS status200 [jsonH] $ cs body
 
     (ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""

src/PostgREST/OpenAPI.hs

@@ -10,7 +10,6 @@ import           Data.ByteString.Lazy        (ByteString)
 import           Data.HashMap.Strict.InsOrd  (InsOrdHashMap, fromList)
 import           Data.String                 (IsString (..))
 import           Data.Text                   (Text, unpack, pack, concat, intercalate)
-import           Network.HTTP.Media          (MediaType)
 import qualified Data.Set                    as Set
 
 import           Prelude hiding              (concat)
@@ -22,8 +21,8 @@ import           PostgREST.Config            (prettyVersion)
 import           PostgREST.QueryBuilder      (operators)
 import           PostgREST.Types             (Table(..), Column(..))
 
-makeMimeList :: [MediaType]
+makeMimeList :: [ContentType] -> MimeList
-makeMimeList = map (fromString . show) [ApplicationJSON, TextCSV]
+makeMimeList cs = MimeList $ map (fromString . show) cs
 
 toSwaggerType :: Text -> SwaggerType t
 toSwaggerType "text"      = SwaggerString
@@ -168,15 +167,15 @@ makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
   where
     tOp = (mempty :: Operation)
       & tags .~ Set.fromList [tn]
-      & produces ?~ MimeList makeMimeList
+      & produces ?~ makeMimeList [ApplicationJSON, TextCSV]
       & at 200 ?~ "OK"
     getOp = tOp
       & parameters .~ map Inline (makeGetParams cs ++ rs)
     postOp = tOp
-      & consumes ?~ MimeList makeMimeList
+      & consumes ?~ makeMimeList [ApplicationJSON, TextCSV]
       & parameters .~ map Inline (makePostParams tn)
     patchOp = tOp
-      & consumes ?~ MimeList makeMimeList
+      & consumes ?~ makeMimeList [ApplicationJSON, TextCSV]
       & parameters .~ map Inline (makePostParams tn ++ rs)
     deletOp = tOp
       & parameters .~ map Inline (makeDeleteParams ++ rs)
@@ -192,7 +191,8 @@ makeRootPathItem = ("/", p)
   where
     getOp = (mempty :: Operation)
       & tags .~ Set.fromList ["/"]
-      & produces ?~ MimeList [(fromString . show) ApplicationJSON]
+      & produces ?~ makeMimeList [ApplicationJSON, OpenAPI]
+      & consumes ?~ makeMimeList [ApplicationJSON, OpenAPI]
       & at 200 ?~ "OK"
     pr = (mempty :: PathItem) & get ?~ getOp
     p = pr

stack.yaml

@@ -19,7 +19,6 @@ extra-deps:
   - unordered-containers-0.2.7.1
   - insert-ordered-containers-0.1.0.1
   - swagger2-2.1
-  - http-media-0.6.3
 ghc-options:
   postgrest: -O2 -Werror -Wall -fwarn-identities
 

test/Feature/StructureSpec.hs

@@ -13,6 +13,54 @@ 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}
+
   describe "Table info" $ do
     it "The structure of complex views is correctly detected" $
       request methodOptions "/filtered_tasks" [] "" `shouldRespondWith`