-- | Renders mig-servers as OpenApi schemas
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
"}")

-- | Reads OpenApi schema for a server
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]

    -- TODO: is it always empty?
    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
                 )

-------------------------------------------------------------------------------------
-- openapi utils

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

-- | Add RequestBody to every operations in the spec.
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

-- | Add parameter to every operation in the spec.
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

-- | Format given text as inline code in Markdown.
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
"`"