module Mig.Core.OpenApi (
toOpenApi,
) where
import Control.Lens (at, (%~), (&), (.~), (?~))
import Data.Aeson (ToJSON (..))
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.HashSet.InsOrd qualified as Set
import Data.Monoid (Endo (..))
import Data.OpenApi hiding (Server (..))
import Data.Proxy
import Data.Text (Text)
import Data.Text qualified as Text
import Mig.Core.Api (Api)
import Mig.Core.Api qualified as Api
import Mig.Core.Class.Route (Route (..))
import Mig.Core.Server (Server (..), fillCaptures)
import Mig.Core.Types.Info (IsRequired (..), RouteInfo)
import Mig.Core.Types.Info qualified as Info
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status (Status (..))
addCapture :: Text -> OpenApi -> OpenApi
addCapture :: Text -> OpenApi -> OpenApi
addCapture Text
captureName =
FilePath -> OpenApi -> OpenApi
prependPath (FilePath
"{" forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
captureName forall a. Semigroup a => a -> a -> a
<> FilePath
"}")
toOpenApi :: Server m -> OpenApi
toOpenApi :: forall (m :: * -> *). Server m -> OpenApi
toOpenApi (Server Api (Route m)
x) = Api RouteInfo -> OpenApi
fromApiInfo (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.info) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Api (Route m) -> Api (Route m)
fillCaptures Api (Route m)
x)
fromApiInfo :: Api RouteInfo -> OpenApi
fromApiInfo :: Api RouteInfo -> OpenApi
fromApiInfo = \case
Api RouteInfo
Api.Empty -> forall a. Monoid a => a
mempty
Api.Append Api RouteInfo
a Api RouteInfo
b -> Api RouteInfo -> OpenApi
fromApiInfo Api RouteInfo
a forall a. Semigroup a => a -> a -> a
<> Api RouteInfo -> OpenApi
fromApiInfo Api RouteInfo
b
Api.WithPath (Api.Path [PathItem]
path) Api RouteInfo
a -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PathItem -> OpenApi -> OpenApi
withPath (Api RouteInfo -> OpenApi
fromApiInfo Api RouteInfo
a) [PathItem]
path
Api.HandleRoute RouteInfo
route -> RouteInfo -> OpenApi
fromRoute RouteInfo
route
withPath :: Api.PathItem -> OpenApi -> OpenApi
withPath :: PathItem -> OpenApi -> OpenApi
withPath = \case
Api.StaticPath Text
pathName -> FilePath -> OpenApi -> OpenApi
prependPath (Text -> FilePath
Text.unpack Text
pathName)
Api.CapturePath Text
captureName -> Text -> OpenApi -> OpenApi
addCapture Text
captureName
fromRoute :: RouteInfo -> OpenApi
fromRoute :: RouteInfo -> OpenApi
fromRoute RouteInfo
routeInfo =
forall a. Endo a -> a -> a
appEndo
(forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. (a -> a) -> Endo a
Endo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Describe RouteInput -> OpenApi -> OpenApi
fromRouteInput) RouteInfo
routeInfo.inputs)
(RouteInfo -> OpenApi
fromRouteOutput RouteInfo
routeInfo)
fromRouteOutput :: RouteInfo -> OpenApi
fromRouteOutput :: RouteInfo -> OpenApi
fromRouteOutput RouteInfo
routeInfo =
forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& forall s a. HasComponents s a => Lens' s a
components forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSchemas s a => Lens' s a
schemas forall s t a b. ASetter s t a b -> b -> s -> t
.~ Definitions Schema
defs
forall a b. a -> (a -> b) -> b
& forall s a. HasPaths s a => Lens' s a
paths forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (InsOrdHashMap FilePath PathItem)
"/"
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& (Maybe Operation -> Identity (Maybe Operation))
-> IxValue (InsOrdHashMap FilePath PathItem)
-> Identity (IxValue (InsOrdHashMap FilePath PathItem))
method
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index Operation
code
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. a -> Referenced a
Inline
( forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& forall s a. HasContent s a => Lens' s a
content
forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList
[(MediaType
t, forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasSchema s a => Lens' s a
schema forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Referenced Schema)
mref) | MediaType
t <- [MediaType]
responseContentTypes]
forall a b. a -> (a -> b) -> b
& forall s a. HasHeaders s a => Lens' s a
headers forall s t a b. ASetter s t a b -> b -> s -> t
.~ InsOrdHashMap Text (Referenced Header)
responseHeaders
)
forall a b. a -> (a -> b) -> b
& forall s a. HasTags s a => Lens' s a
tags forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k. (Eq k, Hashable k) => [k] -> InsOrdHashSet k
Set.fromList RouteInfo
routeInfo.tags
forall a b. a -> (a -> b) -> b
& forall s a. HasSummary s a => Lens' s a
summary forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Maybe Text
nonEmptyText RouteInfo
routeInfo.summary
forall a b. a -> (a -> b) -> b
& forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Maybe Text
nonEmptyText RouteInfo
routeInfo.description
)
)
where
method :: (Maybe Operation -> Identity (Maybe Operation))
-> IxValue (InsOrdHashMap FilePath PathItem)
-> Identity (IxValue (InsOrdHashMap FilePath PathItem))
method = case RouteInfo
routeInfo.method of
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodGet -> forall s a. HasGet s a => Lens' s a
get
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodPost -> forall s a. HasPost s a => Lens' s a
post
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodPut -> forall s a. HasPut s a => Lens' s a
put
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodDelete -> forall s a. HasDelete s a => Lens' s a
delete
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodOptions -> forall s a. HasOptions s a => Lens' s a
options
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodHead -> forall s a. HasHead s a => Lens' s a
head_
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodPatch -> forall s a. HasPatch s a => Lens' s a
patch
Just Method
m | Method
m forall a. Eq a => a -> a -> Bool
== Method
methodTrace -> forall s a. HasTrace s a => Lens' s a
trace
Maybe Method
_ -> forall a. Monoid a => a
mempty
code :: Index Operation
code = RouteInfo
routeInfo.output.status.statusCode
responseContentTypes :: [MediaType]
responseContentTypes = [RouteInfo
routeInfo.output.media]
responseHeaders :: InsOrdHashMap Text (Referenced Header)
responseHeaders = forall a. a -> Referenced a
Inline forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Monoid a => a
mempty
Info.SchemaDefs Definitions Schema
defs Maybe (Referenced Schema)
mref = RouteInfo
routeInfo.output.schema
fromRouteInput :: Info.Describe Info.RouteInput -> OpenApi -> OpenApi
fromRouteInput :: Describe RouteInput -> OpenApi -> OpenApi
fromRouteInput Describe RouteInput
descInput OpenApi
base = case Describe RouteInput
descInput.content of
Info.ReqBodyInput MediaType
inputType SchemaDefs
bodySchema -> MediaType -> SchemaDefs -> OpenApi
onRequestBody MediaType
inputType SchemaDefs
bodySchema
RouteInput
Info.RawBodyInput -> OpenApi
base
Info.CaptureInput Text
captureName Schema
captureSchema -> Text -> Schema -> OpenApi
onCapture Text
captureName Schema
captureSchema
Info.QueryInput IsRequired
isRequired Text
queryName Schema
querySchema -> IsRequired -> Text -> Schema -> OpenApi
onQuery IsRequired
isRequired Text
queryName Schema
querySchema
Info.QueryFlagInput Text
queryName -> Text -> OpenApi
onQueryFlag Text
queryName
Info.HeaderInput IsRequired
isRequired Text
headerName Schema
headerSchema -> IsRequired -> Text -> Schema -> OpenApi
onHeader IsRequired
isRequired Text
headerName Schema
headerSchema
where
onCapture :: Text -> Schema -> OpenApi
onCapture = (Text -> OpenApi -> OpenApi)
-> ParamLocation -> IsRequired -> Text -> Schema -> OpenApi
onParam Text -> OpenApi -> OpenApi
addDefaultResponse404 ParamLocation
ParamPath (Bool -> IsRequired
IsRequired Bool
True)
onQuery :: IsRequired -> Text -> Schema -> OpenApi
onQuery = (Text -> OpenApi -> OpenApi)
-> ParamLocation -> IsRequired -> Text -> Schema -> OpenApi
onParam Text -> OpenApi -> OpenApi
addDefaultResponse400 ParamLocation
ParamQuery
onHeader :: IsRequired -> Text -> Schema -> OpenApi
onHeader = (Text -> OpenApi -> OpenApi)
-> ParamLocation -> IsRequired -> Text -> Schema -> OpenApi
onParam Text -> OpenApi -> OpenApi
addDefaultResponse400 ParamLocation
ParamHeader
onParam :: (Text -> OpenApi -> OpenApi)
-> ParamLocation -> IsRequired -> Text -> Schema -> OpenApi
onParam Text -> OpenApi -> OpenApi
defResponse ParamLocation
paramType (IsRequired Bool
isRequired) Text
paramName Schema
paramSchema =
OpenApi
base
forall a b. a -> (a -> b) -> b
& Param -> OpenApi -> OpenApi
addParam Param
param
forall a b. a -> (a -> b) -> b
& Text -> OpenApi -> OpenApi
defResponse Text
paramName
where
param :: Param
param =
forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& forall s a. HasName s a => Lens' s a
name forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
paramName
forall a b. a -> (a -> b) -> b
& forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Text -> Maybe Text
nonEmptyText forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Describe RouteInput
descInput.description)
forall a b. a -> (a -> b) -> b
& forall s a. HasRequired s a => Lens' s a
required forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
isRequired
forall a b. a -> (a -> b) -> b
& forall s a. HasIn s a => Lens' s a
in_ forall s t a b. ASetter s t a b -> b -> s -> t
.~ ParamLocation
paramType
forall a b. a -> (a -> b) -> b
& forall s a. HasSchema s a => Lens' s a
schema forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (forall a. a -> Referenced a
Inline Schema
paramSchema)
onRequestBody :: MediaType -> SchemaDefs -> OpenApi
onRequestBody MediaType
bodyInputType (Info.SchemaDefs Definitions Schema
defs Maybe (Referenced Schema)
ref) =
OpenApi
base
forall a b. a -> (a -> b) -> b
& RequestBody -> OpenApi -> OpenApi
addRequestBody RequestBody
reqBody
forall a b. a -> (a -> b) -> b
& Text -> OpenApi -> OpenApi
addDefaultResponse400 Text
"body"
forall a b. a -> (a -> b) -> b
& forall s a. HasComponents s a => Lens' s a
components forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasSchemas s a => Lens' s a
schemas forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Definitions Schema
defs)
where
reqBody :: RequestBody
reqBody =
(forall a. Monoid a => a
mempty :: RequestBody)
forall a b. a -> (a -> b) -> b
& forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Text -> Maybe Text
nonEmptyText forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Describe RouteInput
descInput.description)
forall a b. a -> (a -> b) -> b
& forall s a. HasContent s a => Lens' s a
content forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList [(MediaType
t, forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasSchema s a => Lens' s a
schema forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Referenced Schema)
ref) | MediaType
t <- [MediaType
bodyContentType]]
bodyContentType :: MediaType
bodyContentType = MediaType
bodyInputType
onQueryFlag :: Text -> OpenApi
onQueryFlag Text
queryName =
OpenApi
base
forall a b. a -> (a -> b) -> b
& Param -> OpenApi -> OpenApi
addParam Param
param
forall a b. a -> (a -> b) -> b
& Text -> OpenApi -> OpenApi
addDefaultResponse400 Text
queryName
where
param :: Param
param =
forall a. Monoid a => a
mempty
forall a b. a -> (a -> b) -> b
& forall s a. HasName s a => Lens' s a
name forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
queryName
forall a b. a -> (a -> b) -> b
& forall s a. HasIn s a => Lens' s a
in_ forall s t a b. ASetter s t a b -> b -> s -> t
.~ ParamLocation
ParamQuery
forall a b. a -> (a -> b) -> b
& forall s a. HasAllowEmptyValue s a => Lens' s a
allowEmptyValue forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
True
forall a b. a -> (a -> b) -> b
& forall s a. HasSchema s a => Lens' s a
schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ( forall a. a -> Referenced a
Inline forall a b. (a -> b) -> a -> b
$
(forall a. ToParamSchema a => Proxy a -> Schema
toParamSchema (forall {k} (t :: k). Proxy t
Proxy :: Proxy Bool))
forall a b. a -> (a -> b) -> b
& forall s a. HasDefault s a => Lens' s a
default_ forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. ToJSON a => a -> Value
toJSON Bool
False
)
nonEmptyText :: Text -> Maybe Text
nonEmptyText :: Text -> Maybe Text
nonEmptyText Text
txt
| Text -> Bool
Text.null Text
txt = forall a. Maybe a
Nothing
| Bool
otherwise = forall a. a -> Maybe a
Just Text
txt
addRequestBody :: RequestBody -> OpenApi -> OpenApi
addRequestBody :: RequestBody -> OpenApi -> OpenApi
addRequestBody RequestBody
rb = Traversal' OpenApi Operation
allOperations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasRequestBody s a => Lens' s a
requestBody forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. a -> Referenced a
Inline RequestBody
rb
addParam :: Param -> OpenApi -> OpenApi
addParam :: Param -> OpenApi -> OpenApi
addParam Param
param = Traversal' OpenApi Operation
allOperations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasParameters s a => Lens' s a
parameters forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. a -> Referenced a
Inline Param
param :)
addDefaultResponse404 :: ParamName -> OpenApi -> OpenApi
addDefaultResponse404 :: Text -> OpenApi -> OpenApi
addDefaultResponse404 Text
pname = (Response -> Response -> Response)
-> HttpStatusCode
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseWith (\Response
old Response
_new -> Response -> Response
alter404 Response
old) HttpStatusCode
404 (forall (m :: * -> *) a. Monad m => a -> m a
return Response
response404)
where
sname :: Text
sname = Text -> Text
markdownCode Text
pname
description404 :: Text
description404 = Text
sname forall a. Semigroup a => a -> a -> a
<> Text
" not found"
alter404 :: Response -> Response
alter404 = forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((Text
sname forall a. Semigroup a => a -> a -> a
<> Text
" or ") <>)
response404 :: Response
response404 = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
description404
addDefaultResponse400 :: ParamName -> OpenApi -> OpenApi
addDefaultResponse400 :: Text -> OpenApi -> OpenApi
addDefaultResponse400 Text
pname = (Response -> Response -> Response)
-> HttpStatusCode
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseWith (\Response
old Response
_new -> Response -> Response
alter400 Response
old) HttpStatusCode
400 (forall (m :: * -> *) a. Monad m => a -> m a
return Response
response400)
where
sname :: Text
sname = Text -> Text
markdownCode Text
pname
description400 :: Text
description400 = Text
"Invalid " forall a. Semigroup a => a -> a -> a
<> Text
sname
alter400 :: Response -> Response
alter400 = forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> (Text
" or " forall a. Semigroup a => a -> a -> a
<> Text
sname))
response400 :: Response
response400 = forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasDescription s a => Lens' s a
description forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
description400
markdownCode :: Text -> Text
markdownCode :: Text -> Text
markdownCode Text
s = Text
"`" forall a. Semigroup a => a -> a -> a
<> Text
s forall a. Semigroup a => a -> a -> a
<> Text
"`"