Merge pull request #706 from begriffs/func-descriptions

Include RPC endpoints in OpenAPI output
2016-09-24 20:38:42 -07:00
parent f3b79bcc40 a88a704bef
commit 35da4809d4
8 changed files with 171 additions and 30 deletions
@@ -12,6 +12,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 - Filtering, shaping and embedding with &select for the /rpc path - @ruslantalpa
 - Output names of used-defined types (instead of 'USER-DEFINED') - @martingms
 - Implement support for singular representation responses for POST/PATCH requests - @ehamberg
+- Include RPC endpoints in OpenAPI output - @begriffs, @LogvinovLeon

 ### Fixed
 - Do not apply limit to parent items - @ruslantalpa
@@ -151,6 +151,7 @@ Test-Suite spec
                     , SpecHelper
                     , TestTypes
  Build-Depends:       aeson
+                     , aeson-qq
                     , async
                     , base
                     , protolude
@@ -213,7 +213,8 @@ app dbStructure conf apiRequest =
            singular = iPreferSingular apiRequest
            jwtSecret = configJwtSecret conf
            returnType = lookup (qiName qi) $ dbProcs dbStructure
-            returnsJWT = fromMaybe False $ isInfixOf "jwt_claims" <$> returnType
+            returnsJWT = fromMaybe False $
+              isInfixOf "jwt_claims" . pdReturnType <$> returnType
        serves [CTApplicationJSON] (iAccepts apiRequest) $ \_ -> case readSqlParts of
          Left e -> return $ responseLBS status400 [jsonH] $ toS e
          Right (q,cq) -> respondToRange $ do
@@ -233,7 +234,7 @@ app dbStructure conf apiRequest =
          uri Nothing = ("http", host, port, "/")
          uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
          uri' = uri proxy
-          encodeApi ti = encodeOpenAPI ti uri'
+          encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri'
      serves [CTOpenAPI] (iAccepts apiRequest) $ \_ -> do
        body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
        return $ responseLBS status200 [openapiH] $ toS body
@@ -269,7 +270,8 @@ app dbStructure conf apiRequest =
  schema = toS $ configSchema conf
  shouldCount = iPreferCount apiRequest
  topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
-  readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (dbProcs dbStructure) apiRequest
+  mapSnd f (a, b) = (a, f b)
+  readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
  mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest
  selectQuery = requestToQuery schema False <$> readDbRequest
  countQuery = requestToCountQuery schema <$> readDbRequest
@@ -16,7 +16,9 @@ import           Control.Applicative
 import           Data.List                     (elemIndex)
 import           Data.Maybe                    (fromJust)
 import           Data.Monoid
-import           Data.Text                     (split)
+import           Data.Text                     (split, strip,
+                                                breakOn, dropAround)
+import qualified Data.Text                     as T
 import qualified Hasql.Session                 as H
 import           PostgREST.Types
 import           Text.InterpolatedString.Perl6 (q)
@@ -95,12 +97,32 @@ decodeSynonyms cols =
    <*> HD.value HD.text <*> HD.value HD.text
    <*> HD.value HD.text <*> HD.value HD.text

-accessibleProcs :: H.Query Schema [(Text, Text)]
+accessibleProcs :: H.Query Schema [(Text, ProcDescription)]
 accessibleProcs =
-  H.statement sql (HE.value HE.text) (HD.rowsList ((,) <$> HD.value HD.text <*> HD.value HD.text)) True
+  H.statement sql (HE.value HE.text)
+    (map addName <$> HD.rowsList (ProcDescription <$> HD.value HD.text
+                                <*> (parseArgs <$> HD.value HD.text)
+                                <*> HD.value HD.text)) True
 where
+  addName :: ProcDescription -> (Text, ProcDescription)
+  addName pd = (pdName pd, pd)
+
+  parseArgs :: Text -> [PgArg]
+  parseArgs = mapMaybe (parseArg . strip) . split (==',')
+
+  parseArg :: Text -> Maybe PgArg
+  parseArg a =
+    let (body, def) = breakOn " DEFAULT " a
+        (name, typ) = breakOn " " body in
+    if T.null typ
+       then Nothing
+       else Just $
+         PgArg (dropAround (== '"') name) (strip typ) (T.null def)
+
  sql = [q|
-    SELECT p.proname as "proc_name", pg_get_function_result(p.oid) as "return_type"
+    SELECT p.proname as "proc_name",
+           pg_get_function_arguments(p.oid) as "args",
+           pg_get_function_result(p.oid) as "return_type"
    FROM   pg_namespace n
    JOIN   pg_proc p
    ON     pronamespace = n.oid
@@ -23,8 +23,8 @@ import           Data.Swagger
 import           PostgREST.ApiRequest        (ContentType(..), toHeader)
 import           PostgREST.Config            (prettyVersion)
 import           PostgREST.QueryBuilder      (operators)
-import           PostgREST.Types             (Table(..), Column(..),
-                                              Proxy(..))
+import           PostgREST.Types             (Table(..), Column(..), PgArg(..),
+                                              Proxy(..), ProcDescription(..))

 makeMimeList :: [ContentType] -> MimeList
 makeMimeList cs = MimeList $ map (fromString . toS . toHeader) cs
@@ -36,6 +36,13 @@ toSwaggerType "boolean"   = SwaggerBoolean
 toSwaggerType "numeric"   = SwaggerNumber
 toSwaggerType _           = SwaggerString

+makeTableDef :: (Table, [Column], [Text]) -> (Text, Schema)
+makeTableDef (t, cs, _) =
+  let tn = tableName t in
+      (tn, (mempty :: Schema)
+        & type_ .~ SwaggerObject
+        & properties .~ fromList (map makeProperty cs))
+
 makeProperty :: Column -> (Text, Referenced Schema)
 makeProperty c = (colName c, Inline u)
  where
@@ -46,18 +53,20 @@ makeProperty c = (colName c, Inline u)
    t = s & type_ .~ toSwaggerType (colType c)
    u = t & format ?~ colType c

-makeProperties :: [Column] -> InsOrdHashMap Text (Referenced Schema)
-makeProperties cs =  fromList $ map makeProperty cs
+makeProcDef :: ProcDescription -> (Text, Schema)
+makeProcDef pd = ("(rpc) " <> pdName pd, s)
+  where
+    s = (mempty :: Schema)
+          & type_ .~ SwaggerObject
+          & properties .~ fromList (map makeProcProperty (pdArgs pd))
+          & required .~ map pgaName (filter pgaReq (pdArgs pd))

-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
+makeProcProperty :: PgArg -> (Text, Referenced Schema)
+makeProcProperty (PgArg n t _) = (n, Inline s)
+  where
+    s = (mempty :: Schema)
+          & type_ .~ toSwaggerType t
+          & format ?~ t

 makeOperatorPattern :: Text
 makeOperatorPattern =
@@ -173,6 +182,13 @@ makePostParams tn =
    & schema .~ ParamBody (Ref (Reference tn))
  ]

+makeProcParam :: Text -> Param
+makeProcParam refName =
+  (mempty :: Param)
+    & name     .~ "args"
+    & required ?~ True
+    & schema   .~ ParamBody (Ref (Reference refName))
+
 makeDeleteParams :: [Param]
 makeDeleteParams =
  [ makePreferParam ["return=representation", "return=minimal", "return=none"] ]
@@ -204,6 +220,16 @@ makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
    rs = makeRowFilters cs
    tn = tableName t

+makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
+makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
+  where
+    postOp = (mempty :: Operation)
+      & parameters .~ [Inline (makeProcParam $ "(rpc) " <> pdName pd)]
+      & tags .~ Set.fromList ["(rpc) " <> pdName pd]
+      & produces ?~ makeMimeList [CTApplicationJSON]
+      & at 200 ?~ "OK"
+    pe = (mempty :: PathItem) & post ?~ postOp
+
 makeRootPathItem :: (FilePath, PathItem)
 makeRootPathItem = ("/", p)
  where
@@ -214,8 +240,9 @@ makeRootPathItem = ("/", p)
    pr = (mempty :: PathItem) & get ?~ getOp
    p = pr

-makePathItems :: [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
-makePathItems ti = fromList $ makeRootPathItem : map makePathItem ti
+makePathItems :: [ProcDescription] -> [(Table, [Column], [Text])] -> InsOrdHashMap FilePath PathItem
+makePathItems pds ti = fromList $ makeRootPathItem :
+  map makePathItem ti ++ map makeProcPathItem pds

 escapeHostName :: Text -> Text
 escapeHostName "*"  = "0.0.0.0"
@@ -225,8 +252,8 @@ escapeHostName "*6" = "0.0.0.0"
 escapeHostName "!6" = "0.0.0.0"
 escapeHostName h    = h

-postgrestSpec:: [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Swagger
-postgrestSpec ti (s, h, p, b) = (mempty :: Swagger)
+postgrestSpec :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> Swagger
+postgrestSpec pds ti (s, h, p, b) = (mempty :: Swagger)
  & basePath ?~ unpack b
  & schemes ?~ [s']
  & info .~ ((mempty :: Info)
@@ -234,14 +261,14 @@ postgrestSpec ti (s, h, p, b) = (mempty :: Swagger)
      & title .~ "PostgREST API"
      & description ?~ "This is a dynamic API generated by PostgREST")
  & host .~ h'
-  & definitions .~ makeDefinitions ti
-  & paths .~ makePathItems ti
+  & definitions .~ fromList (map makeTableDef ti <> map makeProcDef pds)
+  & paths .~ makePathItems pds ti
    where
      s' = if s == "http" then Http else Https
      h' = Just $ Host (unpack $ escapeHostName h) (Just (fromInteger p))

-encodeOpenAPI :: [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString
-encodeOpenAPI ti uri = encode $ postgrestSpec ti uri
+encodeOpenAPI :: [ProcDescription] -> [(Table, [Column], [Text])] -> (Text, Text, Integer, Text) -> LByteString
+encodeOpenAPI pds ti uri = encode $ postgrestSpec pds ti uri

 {-|
  Test whether a proxy uri is malformed or not.
@@ -13,7 +13,19 @@ data DbStructure = DbStructure {
 , dbColumns     :: [Column]
 , dbRelations   :: [Relation]
 , dbPrimaryKeys :: [PrimaryKey]
-, dbProcs       :: [(Text,Text)]
+, dbProcs       :: [(Text,ProcDescription)]
+} deriving (Show, Eq)
+
+data PgArg = PgArg {
+  pgaName :: Text
+, pgaType :: Text
+, pgaReq  :: Bool
+} deriving (Show, Eq)
+
+data ProcDescription = ProcDescription {
+  pdName       :: Text
+, pdArgs       :: [PgArg]
+, pdReturnType :: Text
 } deriving (Show, Eq)

 type Schema = Text
@@ -4,10 +4,14 @@ import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Network.HTTP.Types

+import Control.Lens ((^?))
+import Data.Aeson.Lens
+import Data.Aeson.QQ
+
 import SpecHelper

 import Network.Wai (Application)
-import Network.Wai.Test (SResponse(simpleHeaders))
+import Network.Wai.Test (SResponse(..))

 spec :: SpecWith Application
 spec = do
@@ -21,6 +25,63 @@ spec = do
              (acceptHdrs "application/openapi+json") ""
        `shouldRespondWith` 415

+    describe "RPC" $
+
+      it "includes a representative function with parameters" $ do
+        r <- simpleBody <$> get "/"
+        let ref = r ^? key "paths" . key "/rpc/varied_arguments"
+                     . key "post"  . key "parameters"
+                     . nth 0       . key "schema"
+                     . key "$ref"  . _String
+            args = r ^? key "definitions" . key "(rpc) varied_arguments"
+
+        liftIO $ do
+          ref `shouldBe` Just "#/definitions/(rpc) varied_arguments"
+          args `shouldBe` Just
+            [aesonQQ|
+              {
+                "required": [
+                  "double",
+                  "varchar",
+                  "boolean",
+                  "date",
+                  "money",
+                  "enum"
+                ],
+                "properties": {
+                  "double": {
+                    "format": "double precision",
+                    "type": "string"
+                  },
+                  "varchar": {
+                    "format": "character varying",
+                    "type": "string"
+                  },
+                  "boolean": {
+                    "format": "boolean",
+                    "type": "boolean"
+                  },
+                  "date": {
+                    "format": "date",
+                    "type": "string"
+                  },
+                  "money": {
+                    "format": "money",
+                    "type": "string"
+                  },
+                  "enum": {
+                    "format": "test.enum_menagerie_type",
+                    "type": "string"
+                  },
+                  "integer": {
+                    "format": "integer",
+                    "type": "integer"
+                  }
+                },
+                "type": "object"
+              }
+            |]
+
  describe "Allow header" $ do

    it "includes read/write verbs for writeable table" $ do
@@ -215,6 +215,21 @@ SELECT rolname::text, id::text FROM postgrest.auth WHERE id = id AND pass = pass
 $$;


+CREATE FUNCTION varied_arguments(
+  double double precision,
+  "varchar" character varying,
+  "boolean" boolean,
+  date date,
+  money money,
+  enum enum_menagerie_type,
+  "integer" integer default 42
+) RETURNS text
+    LANGUAGE sql
+AS $_$
+  SELECT 'Hi'::text;
+$_$;
+
+
 --
 -- Name: jwt_test(); Type: FUNCTION; Schema: test; Owner: -
 --