358 lines
11 KiB
Haskell
358 lines
11 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module PostgREST.OpenAPI (
|
|
encodeOpenAPI
|
|
, isMalformedProxyUri
|
|
, pickProxy
|
|
) where
|
|
|
|
import Control.Lens
|
|
import Data.Aeson (decode, encode)
|
|
import Data.HashMap.Strict.InsOrd (InsOrdHashMap, fromList)
|
|
import Data.Maybe (fromJust)
|
|
import Data.String (IsString (..))
|
|
import Data.Text (unpack, pack, concat, intercalate, init, tail, toLower)
|
|
import qualified Data.Set as Set
|
|
import Network.URI (parseURI, isAbsoluteURI,
|
|
URI (..), URIAuth (..))
|
|
|
|
import Protolude hiding (concat, (&), Proxy, get, intercalate)
|
|
|
|
import Data.Swagger
|
|
|
|
import PostgREST.ApiRequest (ContentType(..), toMime)
|
|
import PostgREST.Config (prettyVersion)
|
|
import PostgREST.QueryBuilder (operators)
|
|
import PostgREST.Types (Table(..), Column(..), PgArg(..),
|
|
Proxy(..), ProcDescription(..))
|
|
|
|
makeMimeList :: [ContentType] -> MimeList
|
|
makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
|
|
|
|
toSwaggerType :: Text -> SwaggerType t
|
|
toSwaggerType "text" = SwaggerString
|
|
toSwaggerType "integer" = SwaggerInteger
|
|
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
|
|
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
|
|
|
|
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))
|
|
|
|
makeProcProperty :: PgArg -> (Text, Referenced Schema)
|
|
makeProcProperty (PgArg n t _) = (n, Inline s)
|
|
where
|
|
s = (mempty :: Schema)
|
|
& type_ .~ toSwaggerType t
|
|
& format ?~ t
|
|
|
|
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 ["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 ["count=none"]
|
|
]
|
|
|
|
makePostParams :: Text -> [Param]
|
|
makePostParams tn =
|
|
[ makePreferParam ["return=representation",
|
|
"return=minimal", "return=none"]
|
|
, (mempty :: Param)
|
|
& name .~ "body"
|
|
& description ?~ tn
|
|
& required ?~ False
|
|
& schema .~ ParamBody (Ref (Reference tn))
|
|
]
|
|
|
|
makeProcParam :: Text -> [Param]
|
|
makeProcParam refName =
|
|
[ makePreferParam ["params=single-object"]
|
|
, (mempty :: Param)
|
|
& name .~ "args"
|
|
& required ?~ True
|
|
& schema .~ ParamBody (Ref (Reference refName))
|
|
]
|
|
|
|
makeDeleteParams :: [Param]
|
|
makeDeleteParams =
|
|
[ makePreferParam ["return=representation", "return=minimal", "return=none"] ]
|
|
|
|
makePathItem :: (Table, [Column], [Text]) -> (FilePath, PathItem)
|
|
makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
|
|
where
|
|
tOp = (mempty :: Operation)
|
|
& tags .~ Set.fromList [tn]
|
|
& produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
|
& at 200 ?~ "OK"
|
|
getOp = tOp
|
|
& parameters .~ map Inline (makeGetParams cs ++ rs)
|
|
& at 206 ?~ "Partial Content"
|
|
postOp = tOp
|
|
& consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
|
& parameters .~ map Inline (makePostParams tn)
|
|
& at 201 ?~ "Created"
|
|
patchOp = tOp
|
|
& consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
|
|
& 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
|
|
|
|
makeProcPathItem :: ProcDescription -> (FilePath, PathItem)
|
|
makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
|
|
where
|
|
postOp = (mempty :: Operation)
|
|
& parameters .~ map Inline (makeProcParam $ "(rpc) " <> pdName pd)
|
|
& tags .~ Set.fromList ["(rpc) " <> pdName pd]
|
|
& produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON]
|
|
& at 200 ?~ "OK"
|
|
pe = (mempty :: PathItem) & post ?~ postOp
|
|
|
|
makeRootPathItem :: (FilePath, PathItem)
|
|
makeRootPathItem = ("/", p)
|
|
where
|
|
getOp = (mempty :: Operation)
|
|
& tags .~ Set.fromList ["/"]
|
|
& produces ?~ makeMimeList [CTOpenAPI]
|
|
& at 200 ?~ "OK"
|
|
pr = (mempty :: PathItem) & get ?~ getOp
|
|
p = pr
|
|
|
|
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"
|
|
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 :: [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)
|
|
& version .~ prettyVersion
|
|
& title .~ "PostgREST API"
|
|
& description ?~ "This is a dynamic API generated by PostgREST")
|
|
& host .~ h'
|
|
& 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 :: [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.
|
|
A valid proxy uri should be an absolute uri without query and user info,
|
|
only http(s) schemes are valid, port number range is 1-65535.
|
|
|
|
For example
|
|
http://postgrest.com/openapi.json
|
|
https://postgrest.com:8080/openapi.json
|
|
-}
|
|
isMalformedProxyUri :: Maybe Text -> Bool
|
|
isMalformedProxyUri Nothing = False
|
|
isMalformedProxyUri (Just uri)
|
|
| isAbsoluteURI (toS uri) = not $ isUriValid $ toURI uri
|
|
| otherwise = True
|
|
|
|
toURI :: Text -> URI
|
|
toURI uri = fromJust $ parseURI (toS uri)
|
|
|
|
pickProxy :: Maybe Text -> Maybe Proxy
|
|
pickProxy proxy
|
|
| isNothing proxy = Nothing
|
|
-- should never happen
|
|
-- since the request would have been rejected by the middleware if proxy uri
|
|
-- is malformed
|
|
| isMalformedProxyUri proxy = Nothing
|
|
| otherwise = Just Proxy {
|
|
proxyScheme = scheme
|
|
, proxyHost = host'
|
|
, proxyPort = port''
|
|
, proxyPath = path'
|
|
}
|
|
where
|
|
uri = toURI $ fromJust proxy
|
|
scheme = init $ toLower $ pack $ uriScheme uri
|
|
path URI {uriPath = ""} = "/"
|
|
path URI {uriPath = p} = p
|
|
path' = pack $ path uri
|
|
authority = fromJust $ uriAuthority uri
|
|
host' = pack $ uriRegName authority
|
|
port' = uriPort authority
|
|
readPort = fromMaybe 80 . readMaybe
|
|
port'' :: Integer
|
|
port'' = case (port', scheme) of
|
|
("", "http") -> 80
|
|
("", "https") -> 443
|
|
_ -> readPort $ unpack $ tail $ pack port'
|
|
|
|
isUriValid:: URI -> Bool
|
|
isUriValid = fAnd [isSchemeValid, isQueryValid, isAuthorityValid]
|
|
|
|
fAnd :: [a -> Bool] -> a -> Bool
|
|
fAnd fs x = all ($x) fs
|
|
|
|
isSchemeValid :: URI -> Bool
|
|
isSchemeValid URI {uriScheme = s}
|
|
| toLower (pack s) == "https:" = True
|
|
| toLower (pack s) == "http:" = True
|
|
| otherwise = False
|
|
|
|
isQueryValid :: URI -> Bool
|
|
isQueryValid URI {uriQuery = ""} = True
|
|
isQueryValid _ = False
|
|
|
|
isAuthorityValid :: URI -> Bool
|
|
isAuthorityValid URI {uriAuthority = a}
|
|
| isJust a = fAnd [isUserInfoValid, isHostValid, isPortValid] $ fromJust a
|
|
| otherwise = False
|
|
|
|
isUserInfoValid :: URIAuth -> Bool
|
|
isUserInfoValid URIAuth {uriUserInfo = ""} = True
|
|
isUserInfoValid _ = False
|
|
|
|
isHostValid :: URIAuth -> Bool
|
|
isHostValid URIAuth {uriRegName = ""} = False
|
|
isHostValid _ = True
|
|
|
|
isPortValid :: URIAuth -> Bool
|
|
isPortValid URIAuth {uriPort = ""} = True
|
|
isPortValid URIAuth {uriPort = (':':p)} =
|
|
case readMaybe p of
|
|
Just i -> i > (0 :: Integer) && i < 65536
|
|
Nothing -> False
|
|
isPortValid _ = False
|