From cf4e157de7835d252b276e96a43fa1549494f99f Mon Sep 17 00:00:00 2001 From: Jacky Hu Date: Tue, 14 Jun 2016 08:39:07 +0800 Subject: [PATCH] Provide a swagger2 spec for the dynamic API Related issue: #144 --- main/Main.hs | 5 +- postgrest.cabal | 25 +++-- src/PostgREST/ApiSpec.hs | 204 +++++++++++++++++++++++++++++++++++++++ src/PostgREST/App.hs | 22 ++++- src/PostgREST/Auth.hs | 4 +- src/PostgREST/Config.hs | 2 + stack.yaml | 6 +- 7 files changed, 254 insertions(+), 14 deletions(-) create mode 100644 src/PostgREST/ApiSpec.hs diff --git a/main/Main.hs b/main/Main.hs index f0fe92de1..24398affe 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -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 diff --git a/postgrest.cabal b/postgrest.cabal index d70ae754e..ee5a412d8 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/PostgREST/ApiSpec.hs b/src/PostgREST/ApiSpec.hs new file mode 100644 index 000000000..d7a1c704c --- /dev/null +++ b/src/PostgREST/ApiSpec.hs @@ -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)) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 0a3c4722a..ac686d368 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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 diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 701ba5f23..ed6591f4f 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -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 diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 1f317c1bb..6f91e3b8f 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -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)) diff --git a/stack.yaml b/stack.yaml index cfe320b1b..5a4acbecf 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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