Provide a swagger2 spec for the dynamic API

Related issue: #144
2016-06-18 10:18:43 +08:00
parent b916ed907b
commit cf4e157de7
7 changed files with 254 additions and 14 deletions
@@ -19,6 +19,7 @@ import qualified Hasql.Decoders                       as HD
 import qualified Hasql.Encoders                       as HE
 import qualified Hasql.Pool                           as P
 import           Network.Wai.Handler.Warp
+import           Network.BSD                          (getHostName)
 import           System.IO                            (BufferMode (..),
                                                       hSetBuffering, stderr,
                                                       stdin, stdout)
@@ -46,7 +47,9 @@ main = do
  hSetBuffering stdin  LineBuffering
  hSetBuffering stderr NoBuffering

-  conf <- readOptions
+  conf' <- readOptions
+  host  <- getHostName
+  conf  <- return conf' { configHost = host }
  let port = configPort conf
      pgSettings = cs (configDatabase conf)
      appSettings = setPort port
@@ -44,8 +44,8 @@ executable postgrest
                     , http-types
                     , interpolatedstring-perl6
                     , jwt
-                     , microlens >= 0.4.2 && < 0.5
-                     , microlens-aeson >= 2.1.1 && < 2.2
+                     , lens >=3.8 && < 5.0
+                     , lens-aeson >= 1.0.0.0 && < 1.1.0.0
                     , mtl
                     , optparse-applicative >= 0.11 && < 0.13
                     , parsec
@@ -65,6 +65,10 @@ executable postgrest
                     , wai-extra
                     , 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
+                     , network >= 2.6.2.1
                     , HTTP
                     , Ranged-sets
  if !os(windows)
@@ -89,8 +93,8 @@ library
                     , http-types
                     , interpolatedstring-perl6
                     , jwt
-                     , microlens
-                     , microlens-aeson
+                     , lens
+                     , lens-aeson
                     , mtl
                     , optparse-applicative
                     , parsec
@@ -109,6 +113,10 @@ library
                     , wai-extra
                     , 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
+                     , network >= 2.6.2.1

  Other-Modules:       Paths_postgrest
  Exposed-Modules:     PostgREST.App
@@ -122,6 +130,7 @@ library
                     , PostgREST.RangeQuery
                     , PostgREST.ApiRequest
                     , PostgREST.Types
+                     , PostgREST.ApiSpec
  hs-source-dirs:      src

 Test-Suite spec
@@ -163,8 +172,8 @@ Test-Suite spec
                     , http-types
                     , interpolatedstring-perl6
                     , jwt
-                     , microlens
-                     , microlens-aeson
+                     , lens
+                     , lens-aeson
                     , monad-control
                     , mtl
                     , optparse-applicative
@@ -186,5 +195,9 @@ Test-Suite spec
                     , wai-extra
                     , wai-middleware-static
                     , warp
+                     , insert-ordered-containers
+                     , http-media
+                     , swagger2
+                     , network
                     , HTTP
                     , Ranged-sets
@@ -0,0 +1,204 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module PostgREST.ApiSpec (
+  apiSpec
+  ) where
+
+import           Control.Lens
+import           Data.Aeson                  (decode, encode)
+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)
+
+import           Data.Swagger
+
+import           PostgREST.ApiRequest        (ContentType(..))
+import           PostgREST.Config            (prettyVersion)
+import           PostgREST.QueryBuilder      (operators)
+import           PostgREST.Types             (Table(..), Column(..))
+
+makeMimeList :: [MediaType]
+makeMimeList = map (fromString . show) [ApplicationJSON, TextCSV]
+
+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 cs = map makeRowFilter cs
+
+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))
+
+makeGetParams :: [Column] -> [Param]
+makeGetParams cs =
+  makeRangeParams ++
+  [ (mempty :: Param)
+    & name        .~ "select"
+    & description ?~ "Filtering Columns"
+    & required    ?~ False
+    & schema .~ ParamOther ((mempty :: ParamOtherSchema)
+      & in_ .~ ParamQuery
+      & type_ .~ SwaggerString)
+  , (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"]
+  ]
+
+makePostParams :: Text -> [Param]
+makePostParams tn =
+  [ makePreferParam ["return=representation", "return=minimal"]
+  , (mempty :: Param)
+    & name        .~ "body"
+    & description ?~ tn
+    & required    ?~ False
+    & schema .~ ParamBody (Ref (Reference tn))
+  ]
+
+makeDeleteParams :: [Param]
+makeDeleteParams =
+  [ makePreferParam ["return=representation", "return=minimal"] ]
+
+makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
+makePathItem (t, cs, _) = ("/" ++ (unpack tn), p $ tableInsertable t)
+  where
+    tOp = (mempty :: Operation)
+      & tags .~ Set.fromList [tn]
+      & produces ?~ MimeList makeMimeList
+      & at 200 ?~ "OK"
+    getOp = tOp
+      & parameters .~ map Inline (makeGetParams cs ++ rs)
+    postOp = tOp
+      & consumes ?~ MimeList makeMimeList
+      & parameters .~ map Inline (makePostParams tn)
+    patchOp = tOp
+      & consumes ?~ MimeList makeMimeList
+      & parameters .~ map Inline (makePostParams tn ++ rs)
+    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
+
+makePathItems :: [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
+makePathItems ti = fromList (map makePathItem ti)
+
+apiSpec :: [(Table, [Column], [Text])] -> String -> Integer -> Swagger
+apiSpec 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 h (Just (fromInteger p))
@@ -9,6 +9,7 @@ module PostgREST.App (
 import           Control.Applicative
 import           Data.Bifunctor            (first)
 import qualified Data.ByteString.Char8   as BS
+import qualified Data.ByteString.Lazy      as BL
 import           Data.IORef                (IORef, readIORef)
 import           Data.List                 (find, delete)
 import           Data.Maybe                (fromMaybe, fromJust, mapMaybe)
@@ -60,6 +61,7 @@ import           PostgREST.QueryBuilder ( callProc
                                        , ResultsWithCount
                                        )
 import           PostgREST.Types
+import           PostgREST.ApiSpec

 import           Prelude

@@ -180,9 +182,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,7 +205,7 @@ app dbStructure conf apiRequest =
        else return notFound

    (ActionRead, TargetRoot, Nothing) -> do
-      body <- encode <$> H.query schema accessibleTables
+      body <- (encodeApi . toTableInfo) <$> H.query schema accessibleTables
      return $ responseLBS status200 [jsonH] $ cs body

    (ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""
@@ -220,8 +219,23 @@ app dbStructure conf apiRequest =
    (_, _, _) -> return notFound

 where
+  toTableInfo :: [Table] -> [(Table, [Column], [Text])]
+  toTableInfo ts = 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)) ts
+  encodeApi :: [(Table, [Column], [Text])] -> BL.ByteString
+  encodeApi ti = encode $ apiSpec ti host port
+  host = configHost conf
+  port = toInteger $ configPort conf
  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
@@ -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)
+  <*> pure "localhost"
  <*> 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))
@@ -16,7 +16,11 @@ extra-deps:
  - wai-cors-0.2.5
  - cryptohash-sha256-0.11.100.0
  - hackage-security-0.5.2.1
-
+  - unordered-containers-0.2.7.1
+  - insert-ordered-containers-0.1.0.1
+  - swagger2-2.1
+  - http-media-0.6.3
+  - network-2.6.2.1
 ghc-options:
  postgrest: -O2 -Werror -Wall -fwarn-identities