Merge pull request #639 from hudayou/swagger2

Provide a swagger2 spec for the dynamic API
2016-06-20 15:12:58 -07:00
parent 46b3ce5631 e571cb9fcb
commit acd75a3997
15 changed files with 2107 additions and 26 deletions
@@ -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 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
@@ -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
@@ -60,6 +60,7 @@ import           PostgREST.QueryBuilder ( callProc
                                        , ResultsWithCount
                                        )
 import           PostgREST.Types
+import           PostgREST.OpenAPI

 import           Prelude

@@ -180,9 +181,6 @@ app dbStructure conf apiRequest =
          let cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
              pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
              body = encode (TableOptions cols pkeys)
-              filterCol :: Schema -> TableName -> Column -> Bool
-              filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
-              filterCol _ _ _ =  False
              acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
          return $ responseLBS status200 [jsonH, allOrigins, acceptH] $ cs body

@@ -206,8 +204,13 @@ app dbStructure conf apiRequest =
        else return notFound

    (ActionRead, TargetRoot, Nothing) -> do
-      body <- encode <$> H.query schema accessibleTables
-      return $ responseLBS status200 [jsonH] $ cs body
+      let encodeApi ti = encodeOpenAPI ti host port
+          host = configHost conf
+          port = toInteger $ configPort conf
+          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] $ cs body

    (ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""

@@ -220,8 +223,19 @@ app dbStructure conf apiRequest =
    (_, _, _) -> return notFound

 where
+  toTableInfo :: [Table] -> [(Table, [Column], [Text])]
+  toTableInfo = map (\t ->
+    let tSchema = tableSchema t
+        tTable = tableName t
+        cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+        pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+     in
+        (t, cols, pkeys))
  notFound = responseLBS status404 [] ""
  filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
+  filterCol :: Schema -> TableName -> Column -> Bool
+  filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
+  filterCol _ _ _ =  False
  allPrKeys = dbPrimaryKeys dbStructure
  allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
  schema = cs $ configSchema conf
@@ -273,6 +287,9 @@ contentRangeH frm to total =
 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"
@@ -18,9 +18,9 @@ module PostgREST.Auth (
  , tokenJWT
  ) where

-import           Lens.Micro
-import           Lens.Micro.Aeson
+import           Control.Lens
 import           Data.Aeson              (Value (..), parseJSON, toJSON)
+import           Data.Aeson.Lens
 import           Data.Aeson.Types        (parseMaybe, emptyObject, emptyArray)
 import qualified Data.ByteString         as BS
 import qualified Data.Vector             as V
@@ -39,6 +39,7 @@ data AppConfig = AppConfig {
    configDatabase  :: String
  , configAnonRole  :: String
  , configSchema    :: String
+  , configHost      :: String
  , configPort      :: Int
  , configJwtSecret :: Secret
  , configPool      :: Int
@@ -51,6 +52,7 @@ argParser = AppConfig
  <$> argument str (help "(REQUIRED) database connection string, e.g. postgres://user:pass@host:port/db" <> metavar "DB_URL")
  <*> strOption    (long "anonymous"  <> short 'a' <> help "(REQUIRED) postgres role to use for non-authenticated requests" <> metavar "ROLE")
  <*> strOption    (long "schema"     <> short 's' <> help "schema to use for API routes" <> metavar "NAME" <> value "public" <> showDefault)
+  <*> strOption    (long "host"       <> short 'l' <> help "hostname or ip on which to run HTTP server" <> metavar "HOST" <> value "*4" <> showDefault)
  <*> option auto  (long "port"       <> short 'p' <> help "port number on which to run HTTP server" <> metavar "PORT" <> value 3000 <> showDefault)
  <*> (secret . cs <$>
      strOption    (long "jwt-secret" <> short 'j' <> help "secret used to encrypt and decrypt JWT tokens" <> metavar "SECRET" <> value "secret" <> showDefault))
@@ -6,6 +6,7 @@ module PostgREST.Middleware where
 import           Data.Aeson                    (Value (..))
 import qualified Data.HashMap.Strict           as M
 import           Data.String.Conversions       (cs)
+import           Data.Maybe                    (fromMaybe, listToMaybe)
 import           Data.Text
 import qualified Hasql.Transaction             as H

@@ -17,7 +18,7 @@ import           Network.Wai.Middleware.Cors   (cors)
 import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)

-import           PostgREST.ApiRequest          (ApiRequest(..), pickContentType)
+import           PostgREST.ApiRequest          (ApiRequest(..), ContentType(..), pickContentType)
 import           PostgREST.Auth                (claimsToSQL)
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 import           PostgREST.Error               (errResponse)
@@ -40,10 +41,14 @@ runWithClaims conf eClaims app req =

 unsupportedAccept :: Application -> Application
 unsupportedAccept app req respond =
-  case accept of
-    Left _ -> respond $ errResponse status415 "Unsupported Accept header, try: application/json"
-    Right _ -> 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 =
@@ -0,0 +1,241 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module PostgREST.OpenAPI (
+  encodeOpenAPI
+  ) where
+
+import           Control.Lens
+import           Data.Aeson                  (decode, encode)
+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 qualified Data.Set                    as Set
+
+import           Prelude hiding              (concat)
+
+import           Data.Swagger
+
+import           PostgREST.ApiRequest        (ContentType(..))
+import           PostgREST.Config            (prettyVersion)
+import           PostgREST.QueryBuilder      (operators)
+import           PostgREST.Types             (Table(..), Column(..))
+
+makeMimeList :: [ContentType] -> MimeList
+makeMimeList cs = MimeList $ map (fromString . show) cs
+
+toSwaggerType :: Text -> SwaggerType t
+toSwaggerType "text"      = SwaggerString
+toSwaggerType "integer"   = SwaggerInteger
+toSwaggerType "boolean"   = SwaggerBoolean
+toSwaggerType "numeric"   = SwaggerNumber
+toSwaggerType _           = SwaggerString
+
+makeProperty :: Column -> (Text, Referenced Schema)
+makeProperty c = (colName c, Inline u)
+  where
+    r = mempty :: Schema
+    s = if null $ colEnum c
+           then r
+           else r & enum_ .~ decode (encode (colEnum c))
+    t = s & type_ .~ toSwaggerType (colType c)
+    u = t & format ?~ colType c
+
+makeProperties :: [Column] -> InsOrdHashMap Text (Referenced Schema)
+makeProperties cs =  fromList $ map makeProperty cs
+
+makeDefinition :: (Table, [Column], [Text]) -> (Text, Schema)
+makeDefinition (t, cs, _) =
+  let tn = tableName t in
+      (tn, (mempty :: Schema)
+        & type_ .~ SwaggerObject
+        & properties .~ makeProperties cs)
+
+makeDefinitions :: [(Table, [Column], [Text])] -> InsOrdHashMap Text Schema
+makeDefinitions ti = fromList $ map makeDefinition ti
+
+makeOperatorPattern :: Text
+makeOperatorPattern =
+  intercalate "|"
+  [ concat ["^", x, y, "[.]"] |
+    x <- ["not[.]", ""],
+    y <- map fst operators ]
+
+makeRowFilter :: Column -> Param
+makeRowFilter c =
+  (mempty :: Param)
+  & name .~ colName c
+  & required ?~ False
+  & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+    & in_ .~ ParamQuery
+    & type_ .~ SwaggerString
+    & format ?~ colType c
+    & pattern ?~ makeOperatorPattern)
+
+makeRowFilters :: [Column] -> [Param]
+makeRowFilters = map makeRowFilter
+
+makeOrderItems :: [Column] -> [Text]
+makeOrderItems cs =
+  [ concat [x, y, z] |
+    x <- map colName cs,
+    y <- [".asc", ".desc", ""],
+    z <- [".nullsfirst", ".nulllast", ""]
+  ]
+
+makeRangeParams :: [Param]
+makeRangeParams =
+  [ (mempty :: Param)
+    & name        .~ "Range"
+    & description ?~ "Limiting and Pagination"
+    & required    ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamHeader
+      & type_ .~ SwaggerString)
+  , (mempty :: Param)
+    & name        .~ "Range-Unit"
+    & description ?~ "Limiting and Pagination"
+    & required    ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamHeader
+      & type_ .~ SwaggerString
+      & default_ .~ decode "\"items\"")
+  , (mempty :: Param)
+    & name        .~ "offset"
+    & description ?~ "Limiting and Pagination"
+    & required    ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+      & type_ .~ SwaggerString)
+  , (mempty :: Param)
+    & name        .~ "limit"
+    & description ?~ "Limiting and Pagination"
+    & required    ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+      & type_ .~ SwaggerString)
+  ]
+
+makePreferParam :: [Text] -> Param
+makePreferParam ts =
+  (mempty :: Param)
+  & name        .~ "Prefer"
+  & description ?~ "Preference"
+  & required    ?~ False
+  & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+    & in_ .~ ParamHeader
+    & type_ .~ SwaggerString
+    & enum_ .~ decode (encode ts))
+
+makeSelectParam :: Param
+makeSelectParam =
+  (mempty :: Param)
+    & name        .~ "select"
+    & description ?~ "Filtering Columns"
+    & required    ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+      & type_ .~ SwaggerString)
+
+makeGetParams :: [Column] -> [Param]
+makeGetParams [] =
+  makeRangeParams ++
+  [ makeSelectParam
+  , makePreferParam ["plurality=singular", "count=none"]
+  ]
+makeGetParams cs =
+  makeRangeParams ++
+  [ makeSelectParam
+  , (mempty :: Param)
+    & name        .~ "order"
+    & description ?~ "Ordering"
+    & required    ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+      & type_ .~ SwaggerString
+      & enum_ .~ decode (encode $ makeOrderItems cs))
+  , makePreferParam ["plurality=singular", "count=none"]
+  ]
+
+makeReturnPreferenceParam :: Param
+makeReturnPreferenceParam =
+  makePreferParam ["return=representation", "return=minimal", "return=none"]
+
+makePostParams :: Text -> [Param]
+makePostParams tn =
+  [ makeReturnPreferenceParam
+  , (mempty :: Param)
+    & name        .~ "body"
+    & description ?~ tn
+    & required    ?~ False
+    & schema .~ ParamBody (Ref (Reference tn))
+  ]
+
+makeDeleteParams :: [Param]
+makeDeleteParams =
+  [ makeReturnPreferenceParam ]
+
+makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
+makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
+  where
+    tOp = (mempty :: Operation)
+      & tags .~ Set.fromList [tn]
+      & produces ?~ makeMimeList [ApplicationJSON, TextCSV]
+      & at 200 ?~ "OK"
+    getOp = tOp
+      & parameters .~ map Inline (makeGetParams cs ++ rs)
+      & at 206 ?~ "Partial Content"
+    postOp = tOp
+      & consumes ?~ makeMimeList [ApplicationJSON, TextCSV]
+      & parameters .~ map Inline (makePostParams tn)
+      & at 201 ?~ "Created"
+    patchOp = tOp
+      & consumes ?~ makeMimeList [ApplicationJSON, TextCSV]
+      & parameters .~ map Inline (makePostParams tn ++ rs)
+      & at 204 ?~ "No Content"
+    deletOp = tOp
+      & parameters .~ map Inline (makeDeleteParams ++ rs)
+    pr = (mempty :: PathItem) & get ?~ getOp
+    pw = pr & post ?~ postOp & patch ?~ patchOp & delete ?~ deletOp
+    p False = pr
+    p True  = pw
+    rs = makeRowFilters cs
+    tn = tableName t
+
+makeRootPathItem :: (FilePath, PathItem)
+makeRootPathItem = ("/", p)
+  where
+    getOp = (mempty :: Operation)
+      & tags .~ Set.fromList ["/"]
+      & produces ?~ makeMimeList [ApplicationJSON, OpenAPI]
+      & at 200 ?~ "OK"
+    pr = (mempty :: PathItem) & get ?~ getOp
+    p = pr
+
+makePathItems :: [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
+makePathItems ti = fromList $ makeRootPathItem : map makePathItem ti
+
+escapeHostName :: String -> String
+escapeHostName "*"  = "0.0.0.0"
+escapeHostName "*4" = "0.0.0.0"
+escapeHostName "!4" = "0.0.0.0"
+escapeHostName "*6" = "0.0.0.0"
+escapeHostName "!6" = "0.0.0.0"
+escapeHostName h    = h
+
+postgrestSpec:: [(Table, [Column], [Text])] -> String -> Integer -> Swagger
+postgrestSpec ti h p = (mempty :: Swagger)
+  & basePath ?~ "/"
+  & schemes ?~ [Http]
+  & info .~ ((mempty :: Info)
+      & version .~ pack prettyVersion
+      & title .~ "PostgREST API"
+      & description ?~ "This is a dynamic API generated by PostgREST")
+  & host .~ h'
+  & definitions .~ makeDefinitions ti
+  & paths .~ makePathItems ti
+    where
+      h' = Just $ Host (escapeHostName h) (Just (fromInteger p))
+
+encodeOpenAPI :: [(Table, [Column], [Text])] -> String -> Integer -> ByteString
+encodeOpenAPI ti h p = encode $ postgrestSpec ti h p