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(..))
import PostgREST.Config (prettyVersion)
import PostgREST.Types (Table(..), Column(..), PgArg(..),
Proxy(..), ProcDescription(..), toMime, Operator(..))
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 show [Equals ..] ]
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, CTApplicationJSON]
& 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
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
| 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