{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE UndecidableInstances #-}

module Okapi.Artifact.OpenApi (endpointToOpenApi, GenericOAPI, openApi) where

import Control.Applicative ((<|>))
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.CaseInsensitive qualified as CI
import Data.Function ((&))
import Data.HashMap.Strict.InsOrd qualified as IHM
import Data.Kind (Type)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.OpenApi (OpenApi, Operation, Param, ParamLocation (..), PathItem (..), Referenced (..), Response, declareSchemaRef, toSchema)
import Data.OpenApi qualified as OA
import Data.OpenApi.Declare (execDeclare)
import Data.OpenApi.Optics ()
import Data.Proxy (Proxy (..))
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Functor.Const (Const (..), getConst)
import Data.List.NonEmpty qualified as NE
import GHC.Generics (C1, D1, Generic (..), K1 (..), M1 (..), Rec0, Rep, S1, (:*:) (..))
import Network.HTTP.Media (MediaType)
import Network.HTTP.Types qualified as HTTP
import Okapi.Mode.Forest (Forest (..), Shape)
import Okapi.Tree (Info (..), Leaf (..))
import Okapi.Record.Tree qualified as Tree
import Okapi.HTTP.Request.Method qualified as Method
import Okapi.HTTP.Request.Path (Path)
import Okapi.HTTP.Request.Path qualified as Path
import Okapi.HTTP.Request.Query (Query)
import Okapi.HTTP.Request.Query qualified as Query
import Okapi.HTTP.Request.Headers qualified as ReqH
import Okapi.HTTP.Request.Body qualified as ReqBody
import Okapi.HTTP.Response.Headers qualified as ResH
import Okapi.HTTP.Response.Body qualified as ResBody
import Okapi.HTTP.Response.Status qualified as Status
import Okapi.HTTP.Responses (Cases, Responses)
import Okapi.HTTP.Responses qualified as Resps
import Okapi.Tree (Tree (..))
import Optics.Core ((%), (.~), (?~))

data PathPiece = PLit Text | PParam Text OA.Schema

walkPath :: Tree Path i o -> [PathPiece] -> [PathPiece]
walkPath :: forall i o. Tree Path i o -> [PathPiece] -> [PathPiece]
walkPath (Node (Path.Seg_ Leaf Path a1
vLeaf a1
x)) [PathPiece]
ps = [PathPiece]
ps [PathPiece] -> [PathPiece] -> [PathPiece]
forall a. [a] -> [a] -> [a]
++ [HeaderName -> PathPiece
PLit (Leaf Path a1
vLeaf.encode a1
x)]
walkPath (Node (Path.Seg HeaderName
n Leaf Path i
vLeaf))  [PathPiece]
ps = [PathPiece]
ps [PathPiece] -> [PathPiece] -> [PathPiece]
forall a. [a] -> [a] -> [a]
++ [HeaderName -> Schema -> PathPiece
PParam HeaderName
n (Info -> Schema
infoSchema Leaf Path i
vLeaf.info)]
walkPath (Node (Path.Segs Leaf Path a1
vLeaf))   [PathPiece]
ps = [PathPiece]
ps [PathPiece] -> [PathPiece] -> [PathPiece]
forall a. [a] -> [a] -> [a]
++ [HeaderName -> Schema -> PathPiece
PParam HeaderName
"segs" (Info -> Schema
infoSchema Leaf Path a1
vLeaf.info)]
walkPath (Node Path i
Path.Raw)            [PathPiece]
ps = [PathPiece]
ps
walkPath (FMap o1 -> o
_ Tree Path i o1
c)   [PathPiece]
ps               = Tree Path i o1 -> [PathPiece] -> [PathPiece]
forall i o. Tree Path i o -> [PathPiece] -> [PathPiece]
walkPath Tree Path i o1
c [PathPiece]
ps
walkPath (LMap i -> i'
_ Tree Path i' o
c)   [PathPiece]
ps               = Tree Path i' o -> [PathPiece] -> [PathPiece]
forall i o. Tree Path i o -> [PathPiece] -> [PathPiece]
walkPath Tree Path i' o
c [PathPiece]
ps
walkPath (Apply Tree Path i (o1 -> o)
cf Tree Path i o1
cx) [PathPiece]
ps              = Tree Path i o1 -> [PathPiece] -> [PathPiece]
forall i o. Tree Path i o -> [PathPiece] -> [PathPiece]
walkPath Tree Path i o1
cx (Tree Path i (o1 -> o) -> [PathPiece] -> [PathPiece]
forall i o. Tree Path i o -> [PathPiece] -> [PathPiece]
walkPath Tree Path i (o1 -> o)
cf [PathPiece]
ps)
walkPath (Pure o
_)      [PathPiece]
ps              = [PathPiece]
ps

pathTemplate :: [PathPiece] -> FilePath
pathTemplate :: [PathPiece] -> FilePath
pathTemplate [PathPiece]
pieces = FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/" ((PathPiece -> FilePath) -> [PathPiece] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PathPiece -> FilePath
piece [PathPiece]
pieces)
  where
    piece :: PathPiece -> FilePath
piece (PLit HeaderName
t)     = HeaderName -> FilePath
T.unpack HeaderName
t
    piece (PParam HeaderName
n Schema
_) = FilePath
"{" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> HeaderName -> FilePath
T.unpack HeaderName
n FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"}"

pathOAParams :: [PathPiece] -> [Param]
pathOAParams :: [PathPiece] -> [Param]
pathOAParams [PathPiece]
pieces =
    [ HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema HeaderName
name ParamLocation
ParamPath Bool
True Schema
sc
    | PParam HeaderName
name Schema
sc <- [PathPiece]
pieces
    ]

extractQueryParams :: Tree Query i o -> [Param]
extractQueryParams :: forall i o. Tree Query i o -> [Param]
extractQueryParams (Node Query i
qry) = case Query i
qry of
    Query.Param  HeaderName
key Leaf Query i
vLeaf   -> [HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema HeaderName
key ParamLocation
ParamQuery Bool
True  (Info -> Schema
infoSchema Leaf Query i
vLeaf.info)]
    Query.Param' HeaderName
key Leaf Query a1
vLeaf   -> [HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema HeaderName
key ParamLocation
ParamQuery Bool
False (Info -> Schema
infoSchema Leaf Query a1
vLeaf.info)]
    Query.Param_ HeaderName
key Leaf Query a1
vLeaf a1
_ -> [HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema HeaderName
key ParamLocation
ParamQuery Bool
True  (Info -> Schema
infoSchema Leaf Query a1
vLeaf.info)]
    Query.Flag   HeaderName
key         -> [HeaderName -> ParamLocation -> Bool -> Param
mkParam HeaderName
key ParamLocation
ParamQuery Bool
True]
    Query.Flag'  HeaderName
key         -> [HeaderName -> ParamLocation -> Bool -> Param
mkParam HeaderName
key ParamLocation
ParamQuery Bool
False]
    Query.List  ArrayStyle
style HeaderName
key Leaf Query a1
_  -> [HeaderName -> Bool -> ArrayStyle -> Param
mkArrayParam HeaderName
key Bool
True  ArrayStyle
style]
    Query.List' ArrayStyle
style HeaderName
key Leaf Query a1
_  -> [HeaderName -> Bool -> ArrayStyle -> Param
mkArrayParam HeaderName
key Bool
False ArrayStyle
style]
    Query i
Query.Raw                -> []
extractQueryParams (FMap o1 -> o
_ Tree Query i o1
c)    = Tree Query i o1 -> [Param]
forall i o. Tree Query i o -> [Param]
extractQueryParams Tree Query i o1
c
extractQueryParams (LMap i -> i'
_ Tree Query i' o
c)    = Tree Query i' o -> [Param]
forall i o. Tree Query i o -> [Param]
extractQueryParams Tree Query i' o
c
extractQueryParams (Apply Tree Query i (o1 -> o)
cf Tree Query i o1
cx) = Tree Query i (o1 -> o) -> [Param]
forall i o. Tree Query i o -> [Param]
extractQueryParams Tree Query i (o1 -> o)
cf [Param] -> [Param] -> [Param]
forall a. [a] -> [a] -> [a]
++ Tree Query i o1 -> [Param]
forall i o. Tree Query i o -> [Param]
extractQueryParams Tree Query i o1
cx
extractQueryParams (Pure o
_)      = []

infoSchema :: Info -> OA.Schema
infoSchema :: Info -> Schema
infoSchema (Info HeaderName
ty Maybe HeaderName
fmt) = Schema -> Schema
withFmt (Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
#type Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> OpenApiType -> Schema -> Schema
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ HeaderName -> OpenApiType
forall {a}. (Eq a, IsString a) => a -> OpenApiType
oaType HeaderName
ty)
  where
    oaType :: a -> OpenApiType
oaType a
"integer" = OpenApiType
OA.OpenApiInteger
    oaType a
"number"  = OpenApiType
OA.OpenApiNumber
    oaType a
"boolean" = OpenApiType
OA.OpenApiBoolean
    oaType a
_         = OpenApiType
OA.OpenApiString
    withFmt :: Schema -> Schema
withFmt Schema
s = Schema -> (HeaderName -> Schema) -> Maybe HeaderName -> Schema
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Schema
s (\HeaderName
f -> Schema
s Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Schema Schema (Maybe HeaderName) (Maybe HeaderName)
#format Optic
  A_Lens NoIx Schema Schema (Maybe HeaderName) (Maybe HeaderName)
-> HeaderName -> Schema -> Schema
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ HeaderName
f) Maybe HeaderName
fmt

extractReqHeaderParams :: Tree ReqH.Headers i o -> [Param]
extractReqHeaderParams :: forall i o. Tree Headers i o -> [Param]
extractReqHeaderParams (Node Headers i
hdr) = case Headers i
hdr of
    ReqH.Field  HeaderName
key Leaf Headers i
vLeaf    -> [HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema (HeaderName -> HeaderName
hdrName HeaderName
key) ParamLocation
ParamHeader Bool
True  (Info -> Schema
infoSchema Leaf Headers i
vLeaf.info)]
    ReqH.Field' HeaderName
key Leaf Headers a1
vLeaf    -> [HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema (HeaderName -> HeaderName
hdrName HeaderName
key) ParamLocation
ParamHeader Bool
False (Info -> Schema
infoSchema Leaf Headers a1
vLeaf.info)]
    Headers i
ReqH.Raw                 -> []
    ReqH.Field_ HeaderName
_ ByteString
_          -> []
    ReqH.FieldRFC9651 HeaderName
n Tree RFC9651 i i
_ -> [HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema (HeaderName -> HeaderName
hdrName HeaderName
n) ParamLocation
ParamHeader Bool
True (Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
#type Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> OpenApiType -> Schema -> Schema
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OA.OpenApiString)]
    ReqH.Cookie  ByteString
_ Leaf Cookie i
_         -> []
    ReqH.Cookie' ByteString
_ Leaf Cookie a1
_         -> []
extractReqHeaderParams (FMap o1 -> o
_ Tree Headers i o1
c)    = Tree Headers i o1 -> [Param]
forall i o. Tree Headers i o -> [Param]
extractReqHeaderParams Tree Headers i o1
c
extractReqHeaderParams (LMap i -> i'
_ Tree Headers i' o
c)    = Tree Headers i' o -> [Param]
forall i o. Tree Headers i o -> [Param]
extractReqHeaderParams Tree Headers i' o
c
extractReqHeaderParams (Apply Tree Headers i (o1 -> o)
cf Tree Headers i o1
cx) = Tree Headers i (o1 -> o) -> [Param]
forall i o. Tree Headers i o -> [Param]
extractReqHeaderParams Tree Headers i (o1 -> o)
cf [Param] -> [Param] -> [Param]
forall a. [a] -> [a] -> [a]
++ Tree Headers i o1 -> [Param]
forall i o. Tree Headers i o -> [Param]
extractReqHeaderParams Tree Headers i o1
cx
extractReqHeaderParams (Pure o
_)      = []

extractResHeaders :: Tree ResH.Headers i o -> [(Text, Bool, OA.Schema)]
extractResHeaders :: forall i o. Tree Headers i o -> [(HeaderName, Bool, Schema)]
extractResHeaders (Node Headers i
hdr) = case Headers i
hdr of
    ResH.Field  HeaderName
key Leaf Headers i
vLeaf    -> [(HeaderName -> HeaderName
hdrName HeaderName
key, Bool
True,  Info -> Schema
infoSchema Leaf Headers i
vLeaf.info)]
    ResH.Field' HeaderName
key Leaf Headers a1
vLeaf    -> [(HeaderName -> HeaderName
hdrName HeaderName
key, Bool
False, Info -> Schema
infoSchema Leaf Headers a1
vLeaf.info)]
    Headers i
ResH.Raw                 -> []
    ResH.Field_ HeaderName
_ ByteString
_          -> []
    ResH.FieldRFC9651 HeaderName
n Tree RFC9651 i i
_ -> [(HeaderName -> HeaderName
hdrName HeaderName
n, Bool
True, Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
#type Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> OpenApiType -> Schema -> Schema
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OA.OpenApiString)]
    ResH.SetCookie ByteString
_ Leaf SetCookie a1
_ Tree Attributes p p
_     -> []
extractResHeaders (FMap o1 -> o
_ Tree Headers i o1
c)    = Tree Headers i o1 -> [(HeaderName, Bool, Schema)]
forall i o. Tree Headers i o -> [(HeaderName, Bool, Schema)]
extractResHeaders Tree Headers i o1
c
extractResHeaders (LMap i -> i'
_ Tree Headers i' o
c)    = Tree Headers i' o -> [(HeaderName, Bool, Schema)]
forall i o. Tree Headers i o -> [(HeaderName, Bool, Schema)]
extractResHeaders Tree Headers i' o
c
extractResHeaders (Apply Tree Headers i (o1 -> o)
cf Tree Headers i o1
cx) = Tree Headers i (o1 -> o) -> [(HeaderName, Bool, Schema)]
forall i o. Tree Headers i o -> [(HeaderName, Bool, Schema)]
extractResHeaders Tree Headers i (o1 -> o)
cf [(HeaderName, Bool, Schema)]
-> [(HeaderName, Bool, Schema)] -> [(HeaderName, Bool, Schema)]
forall a. [a] -> [a] -> [a]
++ Tree Headers i o1 -> [(HeaderName, Bool, Schema)]
forall i o. Tree Headers i o -> [(HeaderName, Bool, Schema)]
extractResHeaders Tree Headers i o1
cx
extractResHeaders (Pure o
_)      = []

extractReqContentType :: Tree ReqH.Headers i o -> Maybe ByteString
extractReqContentType :: forall i o. Tree Headers i o -> Maybe ByteString
extractReqContentType (Node (ReqH.Field_ HeaderName
k ByteString
v)) | HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"content-type" = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
v
extractReqContentType (FMap o1 -> o
_ Tree Headers i o1
c)    = Tree Headers i o1 -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractReqContentType Tree Headers i o1
c
extractReqContentType (LMap i -> i'
_ Tree Headers i' o
c)    = Tree Headers i' o -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractReqContentType Tree Headers i' o
c
extractReqContentType (Apply Tree Headers i (o1 -> o)
cf Tree Headers i o1
cx) = Tree Headers i (o1 -> o) -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractReqContentType Tree Headers i (o1 -> o)
cf Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tree Headers i o1 -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractReqContentType Tree Headers i o1
cx
extractReqContentType Tree Headers i o
_             = Maybe ByteString
forall a. Maybe a
Nothing

extractResContentType :: Tree ResH.Headers i o -> Maybe ByteString
extractResContentType :: forall i o. Tree Headers i o -> Maybe ByteString
extractResContentType (Node (ResH.Field_ HeaderName
k ByteString
v)) | HeaderName
k HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
"content-type" = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
v
extractResContentType (FMap o1 -> o
_ Tree Headers i o1
c)    = Tree Headers i o1 -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractResContentType Tree Headers i o1
c
extractResContentType (LMap i -> i'
_ Tree Headers i' o
c)    = Tree Headers i' o -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractResContentType Tree Headers i' o
c
extractResContentType (Apply Tree Headers i (o1 -> o)
cf Tree Headers i o1
cx) = Tree Headers i (o1 -> o) -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractResContentType Tree Headers i (o1 -> o)
cf Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tree Headers i o1 -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractResContentType Tree Headers i o1
cx
extractResContentType Tree Headers i o
_             = Maybe ByteString
forall a. Maybe a
Nothing

bodySchemaOf :: forall (b :: Type -> Type) a. ReqBody.IsoJson a => b (IO a) -> OA.Schema
bodySchemaOf :: forall (b :: * -> *) a. IsoJson a => b (IO a) -> Schema
bodySchemaOf b (IO a)
_ = Proxy a -> Schema
forall a. ToSchema a => Proxy a -> Schema
toSchema (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

bodyDefsOf :: forall (b :: Type -> Type) a. ReqBody.IsoJson a => b (IO a) -> OA.Definitions OA.Schema
bodyDefsOf :: forall (b :: * -> *) a. IsoJson a => b (IO a) -> Definitions Schema
bodyDefsOf b (IO a)
_ = Declare (Definitions Schema) (Referenced Schema)
-> Definitions Schema -> Definitions Schema
forall d a. Declare d a -> d -> d
execDeclare (Proxy a -> Declare (Definitions Schema) (Referenced Schema)
forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)) Definitions Schema
forall a. Monoid a => a
mempty

extractReqBodySchema :: Tree ReqBody.Body i o -> Maybe OA.Schema
extractReqBodySchema :: forall i o. Tree Body i o -> Maybe Schema
extractReqBodySchema (Node Body i
body) = case Body i
body of
    Body i
ReqBody.Json -> Schema -> Maybe Schema
forall a. a -> Maybe a
Just (Body (IO a1) -> Schema
forall (b :: * -> *) a. IsoJson a => b (IO a) -> Schema
bodySchemaOf Body i
Body (IO a1)
body)
    Body i
_            -> Maybe Schema
forall a. Maybe a
Nothing
extractReqBodySchema (FMap o1 -> o
_ Tree Body i o1
c)    = Tree Body i o1 -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractReqBodySchema Tree Body i o1
c
extractReqBodySchema (LMap i -> i'
_ Tree Body i' o
c)    = Tree Body i' o -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractReqBodySchema Tree Body i' o
c
extractReqBodySchema (Apply Tree Body i (o1 -> o)
cf Tree Body i o1
cx) = Tree Body i (o1 -> o) -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractReqBodySchema Tree Body i (o1 -> o)
cf Maybe Schema -> Maybe Schema -> Maybe Schema
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tree Body i o1 -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractReqBodySchema Tree Body i o1
cx
extractReqBodySchema (Pure o
_)      = Maybe Schema
forall a. Maybe a
Nothing

extractReqBodyDefs :: Tree ReqBody.Body i o -> OA.Definitions OA.Schema
extractReqBodyDefs :: forall i o. Tree Body i o -> Definitions Schema
extractReqBodyDefs (Node Body i
body) = case Body i
body of
    Body i
ReqBody.Json -> Body (IO a1) -> Definitions Schema
forall (b :: * -> *) a. IsoJson a => b (IO a) -> Definitions Schema
bodyDefsOf Body i
Body (IO a1)
body
    Body i
_            -> Definitions Schema
forall a. Monoid a => a
mempty
extractReqBodyDefs (FMap o1 -> o
_ Tree Body i o1
c)    = Tree Body i o1 -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractReqBodyDefs Tree Body i o1
c
extractReqBodyDefs (LMap i -> i'
_ Tree Body i' o
c)    = Tree Body i' o -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractReqBodyDefs Tree Body i' o
c
extractReqBodyDefs (Apply Tree Body i (o1 -> o)
cf Tree Body i o1
cx) = Tree Body i (o1 -> o) -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractReqBodyDefs Tree Body i (o1 -> o)
cf Definitions Schema -> Definitions Schema -> Definitions Schema
forall a. Semigroup a => a -> a -> a
<> Tree Body i o1 -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractReqBodyDefs Tree Body i o1
cx
extractReqBodyDefs (Pure o
_)      = Definitions Schema
forall a. Monoid a => a
mempty

extractResBodySchema :: Tree ResBody.Body i o -> Maybe OA.Schema
extractResBodySchema :: forall i o. Tree Body i o -> Maybe Schema
extractResBodySchema (Node Body i
body) = case Body i
body of
    Body i
ResBody.Json -> Schema -> Maybe Schema
forall a. a -> Maybe a
Just (Body (IO a1) -> Schema
forall (b :: * -> *) a. IsoJson a => b (IO a) -> Schema
bodySchemaOf Body i
Body (IO a1)
body)
    Body i
_            -> Maybe Schema
forall a. Maybe a
Nothing
extractResBodySchema (FMap o1 -> o
_ Tree Body i o1
c)    = Tree Body i o1 -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractResBodySchema Tree Body i o1
c
extractResBodySchema (LMap i -> i'
_ Tree Body i' o
c)    = Tree Body i' o -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractResBodySchema Tree Body i' o
c
extractResBodySchema (Apply Tree Body i (o1 -> o)
cf Tree Body i o1
cx) = Tree Body i (o1 -> o) -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractResBodySchema Tree Body i (o1 -> o)
cf Maybe Schema -> Maybe Schema -> Maybe Schema
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tree Body i o1 -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractResBodySchema Tree Body i o1
cx
extractResBodySchema (Pure o
_)      = Maybe Schema
forall a. Maybe a
Nothing

extractResBodyDefs :: Tree ResBody.Body i o -> OA.Definitions OA.Schema
extractResBodyDefs :: forall i o. Tree Body i o -> Definitions Schema
extractResBodyDefs (Node Body i
body) = case Body i
body of
    Body i
ResBody.Json -> Body (IO a1) -> Definitions Schema
forall (b :: * -> *) a. IsoJson a => b (IO a) -> Definitions Schema
bodyDefsOf Body i
Body (IO a1)
body
    Body i
_            -> Definitions Schema
forall a. Monoid a => a
mempty
extractResBodyDefs (FMap o1 -> o
_ Tree Body i o1
c)    = Tree Body i o1 -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractResBodyDefs Tree Body i o1
c
extractResBodyDefs (LMap i -> i'
_ Tree Body i' o
c)    = Tree Body i' o -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractResBodyDefs Tree Body i' o
c
extractResBodyDefs (Apply Tree Body i (o1 -> o)
cf Tree Body i o1
cx) = Tree Body i (o1 -> o) -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractResBodyDefs Tree Body i (o1 -> o)
cf Definitions Schema -> Definitions Schema -> Definitions Schema
forall a. Semigroup a => a -> a -> a
<> Tree Body i o1 -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractResBodyDefs Tree Body i o1
cx
extractResBodyDefs (Pure o
_)      = Definitions Schema
forall a. Monoid a => a
mempty

data ResInfo = ResInfo
    { ResInfo -> Status
resStatus     :: HTTP.Status
    , ResInfo -> Maybe ByteString
resMediaType  :: Maybe ByteString
    , ResInfo -> Maybe Schema
resBodySchema :: Maybe OA.Schema
    , ResInfo -> Definitions Schema
resBodyDefs   :: OA.Definitions OA.Schema
    , ResInfo -> [(HeaderName, Bool, Schema)]
resHdrNames   :: [(Text, Bool, OA.Schema)]
    }

resStatusOf :: Status.Status s -> HTTP.Status
resStatusOf :: forall s. Status s -> Status
resStatusOf Status s
Status.Raw        = Status
HTTP.status200
resStatusOf (Status.Status KnownStatus s
ks) = KnownStatus s -> Status
forall (s :: Nat). KnownStatus s -> Status
Status.knownStatusToHTTP KnownStatus s
ks

resInfoOf :: Tree.Response s h b -> ResInfo
resInfoOf :: forall s h b. Response s h b -> ResInfo
resInfoOf Response s h b
res = ResInfo
    { resStatus :: Status
resStatus     = Status s -> Status
forall s. Status s -> Status
resStatusOf Response s h b
res.status
    , resMediaType :: Maybe ByteString
resMediaType  = Tree Headers h h -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractResContentType Response s h b
res.headers
    , resBodySchema :: Maybe Schema
resBodySchema = Tree Body b b -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractResBodySchema Response s h b
res.body
    , resBodyDefs :: Definitions Schema
resBodyDefs   = Tree Body b b -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractResBodyDefs Response s h b
res.body
    , resHdrNames :: [(HeaderName, Bool, Schema)]
resHdrNames   = Tree Headers h h -> [(HeaderName, Bool, Schema)]
forall i o. Tree Headers i o -> [(HeaderName, Bool, Schema)]
extractResHeaders Response s h b
res.headers
    }

extractResInfos :: Cases responses => Responses Tree.Response responses -> [ResInfo]
extractResInfos :: forall (responses :: (* -> * -> * -> *) -> *).
Cases responses =>
Responses Response responses -> [ResInfo]
extractResInfos Responses Response responses
rs =
    (responses Response -> ResInfo)
-> [responses Response] -> [ResInfo]
forall a b. (a -> b) -> [a] -> [b]
map
        (Const ResInfo (responses Response) -> ResInfo
forall {k} a (b :: k). Const a b -> a
getConst (Const ResInfo (responses Response) -> ResInfo)
-> (responses Response -> Const ResInfo (responses Response))
-> responses Response
-> ResInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> * -> * -> *) (g :: * -> * -> * -> *)
       (responses :: (* -> * -> * -> *) -> *) (t :: * -> *).
(Generic (responses f), Generic (responses g),
 GTraverse f g (Rep (responses f)) (Rep (responses g)),
 Functor t) =>
(forall status headers body.
 f status headers body -> t (g status headers body))
-> responses f -> t (responses g)
Resps.traverseResponses @Tree.Response @Tree.Response (\Response status headers body
c -> ResInfo -> Const ResInfo (Response status headers body)
forall {k} a (b :: k). a -> Const a b
Const (Response status headers body -> ResInfo
forall s h b. Response s h b -> ResInfo
resInfoOf Response status headers body
c)))
        (NonEmpty (responses Response) -> [responses Response]
forall a. NonEmpty a -> [a]
NE.toList (Responses Response responses -> NonEmpty (responses Response)
forall (f :: * -> * -> * -> *)
       (responses :: (* -> * -> * -> *) -> *).
Responses f responses -> NonEmpty (responses f)
Resps.getResponses Responses Response responses
rs))

methodStdOf :: Method.Method m -> Maybe HTTP.StdMethod
methodStdOf :: forall m. Method m -> Maybe StdMethod
methodStdOf Method m
Method.Raw        = Maybe StdMethod
forall a. Maybe a
Nothing
methodStdOf (Method.Method KnownMethod m
km) = StdMethod -> Maybe StdMethod
forall a. a -> Maybe a
Just (KnownMethod m -> StdMethod
forall (m :: Symbol). KnownMethod m -> StdMethod
Method.knownMethodToStd KnownMethod m
km)

hdrName :: HTTP.HeaderName -> Text
hdrName :: HeaderName -> HeaderName
hdrName = FilePath -> HeaderName
T.pack (FilePath -> HeaderName)
-> (HeaderName -> FilePath) -> HeaderName -> HeaderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BS8.unpack (ByteString -> FilePath)
-> (HeaderName -> ByteString) -> HeaderName -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ByteString
forall s. CI s -> s
CI.original

mkParam :: Text -> ParamLocation -> Bool -> Param
mkParam :: HeaderName -> ParamLocation -> Bool -> Param
mkParam HeaderName
n ParamLocation
loc Bool
req_ =
    Param
forall a. Monoid a => a
mempty
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param HeaderName HeaderName
#name Optic A_Lens NoIx Param Param HeaderName HeaderName
-> HeaderName -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ HeaderName
n
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param ParamLocation ParamLocation
#in Optic A_Lens NoIx Param Param ParamLocation ParamLocation
-> ParamLocation -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ParamLocation
loc
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
#required Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
-> Bool -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Bool
req_

mkParamWithSchema :: Text -> ParamLocation -> Bool -> OA.Schema -> Param
mkParamWithSchema :: HeaderName -> ParamLocation -> Bool -> Schema -> Param
mkParamWithSchema HeaderName
n ParamLocation
loc Bool
req_ Schema
sc =
    Param
forall a. Monoid a => a
mempty
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param HeaderName HeaderName
#name Optic A_Lens NoIx Param Param HeaderName HeaderName
-> HeaderName -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ HeaderName
n
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param ParamLocation ParamLocation
#in Optic A_Lens NoIx Param Param ParamLocation ParamLocation
-> ParamLocation -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ParamLocation
loc
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
#required Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
-> Bool -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Bool
req_
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  Param
  Param
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
#schema Optic
  A_Lens
  NoIx
  Param
  Param
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
-> Referenced Schema -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
sc

mkArrayParam :: Text -> Bool -> Query.ArrayStyle -> Param
mkArrayParam :: HeaderName -> Bool -> ArrayStyle -> Param
mkArrayParam HeaderName
n Bool
req_ ArrayStyle
style =
    Param
forall a. Monoid a => a
mempty
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param HeaderName HeaderName
#name Optic A_Lens NoIx Param Param HeaderName HeaderName
-> HeaderName -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ HeaderName
n
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param ParamLocation ParamLocation
#in Optic A_Lens NoIx Param Param ParamLocation ParamLocation
-> ParamLocation -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ ParamLocation
ParamQuery
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
#required Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
-> Bool -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Bool
req_
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param (Maybe Style) (Maybe Style)
#style Optic A_Lens NoIx Param Param (Maybe Style) (Maybe Style)
-> Style -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Style
st
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
#explode Optic A_Lens NoIx Param Param (Maybe Bool) (Maybe Bool)
-> Bool -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Bool
ex
        Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  Param
  Param
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
#schema Optic
  A_Lens
  NoIx
  Param
  Param
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
-> Referenced Schema -> Param -> Param
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
arraySchema
  where
    arraySchema :: Schema
arraySchema =
        Schema
forall a. Monoid a => a
mempty
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
#type Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> OpenApiType -> Schema -> Schema
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OA.OpenApiArray
            Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
#items Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiItems) (Maybe OpenApiItems)
-> OpenApiItems -> Schema -> Schema
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> OpenApiItems
OA.OpenApiItemsObject (Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
#type Optic
  A_Lens NoIx Schema Schema (Maybe OpenApiType) (Maybe OpenApiType)
-> OpenApiType -> Schema -> Schema
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OA.OpenApiString))
    (Style
st, Bool
ex) = case ArrayStyle
style of
        ArrayStyle
Query.Exploded       -> (Style
OA.StyleForm, Bool
True)
        ArrayStyle
Query.CommaDelimited -> (Style
OA.StyleForm, Bool
False)
        ArrayStyle
Query.SpaceDelimited -> (Style
OA.StyleSpaceDelimited, Bool
False)
        ArrayStyle
Query.PipeDelimited  -> (Style
OA.StylePipeDelimited, Bool
False)

mkResResponse :: ResInfo -> Response
mkResResponse :: ResInfo -> Response
mkResResponse ResInfo
ri =
    Response
forall a. Monoid a => a
mempty
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Response Response HeaderName HeaderName
#description Optic A_Lens NoIx Response Response HeaderName HeaderName
-> HeaderName -> Response -> Response
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FilePath -> HeaderName
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Status -> Int
HTTP.statusCode (ResInfo -> Status
resStatus ResInfo
ri)))
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Maybe ByteString -> Maybe Schema -> Response -> Response
applyResBodySchema (ResInfo -> Maybe ByteString
resMediaType ResInfo
ri) (ResInfo -> Maybe Schema
resBodySchema ResInfo
ri)
        Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& [(HeaderName, Bool, Schema)] -> Response -> Response
applyResHeaders (ResInfo -> [(HeaderName, Bool, Schema)]
resHdrNames ResInfo
ri)

applyResBodySchema :: Maybe ByteString -> Maybe OA.Schema -> Response -> Response
applyResBodySchema :: Maybe ByteString -> Maybe Schema -> Response -> Response
applyResBodySchema Maybe ByteString
_ Maybe Schema
Nothing Response
r = Response
r
applyResBodySchema Maybe ByteString
mt (Just Schema
sc) Response
r =
    Response
r Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  Response
  Response
  (InsOrdHashMap MediaType MediaTypeObject)
  (InsOrdHashMap MediaType MediaTypeObject)
#content Optic
  A_Lens
  NoIx
  Response
  Response
  (InsOrdHashMap MediaType MediaTypeObject)
  (InsOrdHashMap MediaType MediaTypeObject)
-> InsOrdHashMap MediaType MediaTypeObject -> Response -> Response
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
IHM.singleton (Maybe ByteString -> MediaType
mediaKey Maybe ByteString
mt) (MediaTypeObject
forall a. Monoid a => a
mempty MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  MediaTypeObject
  MediaTypeObject
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
#schema Optic
  A_Lens
  NoIx
  MediaTypeObject
  MediaTypeObject
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
sc)

applyResHeaders :: [(Text, Bool, OA.Schema)] -> Response -> Response
applyResHeaders :: [(HeaderName, Bool, Schema)] -> Response -> Response
applyResHeaders [] Response
r = Response
r
applyResHeaders [(HeaderName, Bool, Schema)]
hs Response
r =
    Response
r Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  Response
  Response
  (InsOrdHashMap HeaderName (Referenced Header))
  (InsOrdHashMap HeaderName (Referenced Header))
#headers Optic
  A_Lens
  NoIx
  Response
  Response
  (InsOrdHashMap HeaderName (Referenced Header))
  (InsOrdHashMap HeaderName (Referenced Header))
-> InsOrdHashMap HeaderName (Referenced Header)
-> Response
-> Response
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [(HeaderName, Referenced Header)]
-> InsOrdHashMap HeaderName (Referenced Header)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
IHM.fromList
        [ (HeaderName
name, Header -> Referenced Header
forall a. a -> Referenced a
Inline (Header
forall a. Monoid a => a
mempty Header -> (Header -> Header) -> Header
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Header Header (Maybe Bool) (Maybe Bool)
#required Optic A_Lens NoIx Header Header (Maybe Bool) (Maybe Bool)
-> Bool -> Header -> Header
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Bool
req_ Header -> (Header -> Header) -> Header
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  Header
  Header
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
#schema Optic
  A_Lens
  NoIx
  Header
  Header
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
-> Referenced Schema -> Header -> Header
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
sc))
        | (HeaderName
name, Bool
req_, Schema
sc) <- [(HeaderName, Bool, Schema)]
hs
        ]

applyReqBodySchema :: Maybe ByteString -> Maybe OA.Schema -> Operation -> Operation
applyReqBodySchema :: Maybe ByteString -> Maybe Schema -> Operation -> Operation
applyReqBodySchema Maybe ByteString
_ Maybe Schema
Nothing Operation
op = Operation
op
applyReqBodySchema Maybe ByteString
mt (Just Schema
sc) Operation
op =
    Operation
op Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  Operation
  Operation
  (Maybe (Referenced RequestBody))
  (Maybe (Referenced RequestBody))
#requestBody Optic
  A_Lens
  NoIx
  Operation
  Operation
  (Maybe (Referenced RequestBody))
  (Maybe (Referenced RequestBody))
-> Referenced RequestBody -> Operation -> Operation
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ RequestBody -> Referenced RequestBody
forall a. a -> Referenced a
Inline
        ( RequestBody
forall a. Monoid a => a
mempty RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  RequestBody
  RequestBody
  (InsOrdHashMap MediaType MediaTypeObject)
  (InsOrdHashMap MediaType MediaTypeObject)
#content Optic
  A_Lens
  NoIx
  RequestBody
  RequestBody
  (InsOrdHashMap MediaType MediaTypeObject)
  (InsOrdHashMap MediaType MediaTypeObject)
-> InsOrdHashMap MediaType MediaTypeObject
-> RequestBody
-> RequestBody
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
IHM.singleton (Maybe ByteString -> MediaType
mediaKey Maybe ByteString
mt) (MediaTypeObject
forall a. Monoid a => a
mempty MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  MediaTypeObject
  MediaTypeObject
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
#schema Optic
  A_Lens
  NoIx
  MediaTypeObject
  MediaTypeObject
  (Maybe (Referenced Schema))
  (Maybe (Referenced Schema))
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
sc) )

mediaKey :: Maybe ByteString -> MediaType
mediaKey :: Maybe ByteString -> MediaType
mediaKey = MediaType
-> (ByteString -> MediaType) -> Maybe ByteString -> MediaType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe MediaType
"application/json" (FilePath -> MediaType
forall a. IsString a => FilePath -> a
fromString (FilePath -> MediaType)
-> (ByteString -> FilePath) -> ByteString -> MediaType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
BS8.unpack)

setMethod :: HTTP.StdMethod -> Operation -> PathItem -> PathItem
setMethod :: StdMethod -> Operation -> PathItem -> PathItem
setMethod StdMethod
HTTP.GET    Operation
op PathItem
pi_ = PathItem
pi_{_pathItemGet    = Just op}
setMethod StdMethod
HTTP.POST   Operation
op PathItem
pi_ = PathItem
pi_{_pathItemPost   = Just op}
setMethod StdMethod
HTTP.PUT    Operation
op PathItem
pi_ = PathItem
pi_{_pathItemPut    = Just op}
setMethod StdMethod
HTTP.DELETE Operation
op PathItem
pi_ = PathItem
pi_{_pathItemDelete = Just op}
setMethod StdMethod
_           Operation
op PathItem
pi_ = PathItem
pi_{_pathItemGet    = Just op}

endpointToOpenApi :: Forest (Shape method path query headers body result) -> OpenApi
endpointToOpenApi :: forall method path query headers body result.
Forest (Shape method path query headers body result) -> OpenApi
endpointToOpenApi Forest (Shape method path query headers body result)
endpoint = case Forest (Shape method path query headers body result)
endpoint of
    (Request method path query headers body
req :-> Response status resHeaders resBody
singleRes) -> Request method path query headers body -> [ResInfo] -> OpenApi
forall {k} {k} {k} {k} {r} {i} {o} {m} {i} {o} {i} {o} {i} {o} {a}
       {b} {b} {k} {l} {k} {l} {k} {l} {u} {v} {a} {a} {a} {u} {v} {b} {a}
       {a} {u} {v} {a} {a}.
(Is k A_Setter, Is k A_Setter, Is k A_Setter, Is k A_Setter,
 HasField "path" r (Tree Path i o), HasField "method" r (Method m),
 HasField "query" r (Tree Query i o),
 HasField "headers" r (Tree Headers i o),
 HasField "body" r (Tree Body i o), Monoid a, IsString b,
 IsString b, JoinKinds k l k, JoinKinds k l k, JoinKinds k l k,
 LabelOptic "version" l u v a b, LabelOptic "components" k a a u v,
 LabelOptic "paths" k a b a (InsOrdHashMap FilePath PathItem),
 LabelOptic "info" k a a u v, LabelOptic "info" k a a u v,
 LabelOptic "schemas" l u v a (Definitions Schema),
 LabelOptic "title" l u v a b) =>
r -> [ResInfo] -> b
toOpenApi Request method path query headers body
req [Response status resHeaders resBody -> ResInfo
forall s h b. Response s h b -> ResInfo
resInfoOf Response status resHeaders resBody
singleRes]
    (Request method path query headers body
req :-< Responses Response responses
resAlt)    -> Request method path query headers body -> [ResInfo] -> OpenApi
forall {k} {k} {k} {k} {r} {i} {o} {m} {i} {o} {i} {o} {i} {o} {a}
       {b} {b} {k} {l} {k} {l} {k} {l} {u} {v} {a} {a} {a} {u} {v} {b} {a}
       {a} {u} {v} {a} {a}.
(Is k A_Setter, Is k A_Setter, Is k A_Setter, Is k A_Setter,
 HasField "path" r (Tree Path i o), HasField "method" r (Method m),
 HasField "query" r (Tree Query i o),
 HasField "headers" r (Tree Headers i o),
 HasField "body" r (Tree Body i o), Monoid a, IsString b,
 IsString b, JoinKinds k l k, JoinKinds k l k, JoinKinds k l k,
 LabelOptic "version" l u v a b, LabelOptic "components" k a a u v,
 LabelOptic "paths" k a b a (InsOrdHashMap FilePath PathItem),
 LabelOptic "info" k a a u v, LabelOptic "info" k a a u v,
 LabelOptic "schemas" l u v a (Definitions Schema),
 LabelOptic "title" l u v a b) =>
r -> [ResInfo] -> b
toOpenApi Request method path query headers body
req (Responses Response responses -> [ResInfo]
forall (responses :: (* -> * -> * -> *) -> *).
Cases responses =>
Responses Response responses -> [ResInfo]
extractResInfos Responses Response responses
resAlt)
  where
    toOpenApi :: r -> [ResInfo] -> b
toOpenApi r
req [ResInfo]
resInfos =
        let
            stdMeth :: StdMethod
stdMeth = StdMethod -> Maybe StdMethod -> StdMethod
forall a. a -> Maybe a -> a
fromMaybe StdMethod
HTTP.GET (Method m -> Maybe StdMethod
forall m. Method m -> Maybe StdMethod
methodStdOf r
req.method)
            pieces :: [PathPiece]
pieces  = Tree Path i o -> [PathPiece] -> [PathPiece]
forall i o. Tree Path i o -> [PathPiece] -> [PathPiece]
walkPath r
req.path []
            qParams :: [Param]
qParams = Tree Query i o -> [Param]
forall i o. Tree Query i o -> [Param]
extractQueryParams r
req.query
            hParams :: [Param]
hParams = Tree Headers i o -> [Param]
forall i o. Tree Headers i o -> [Param]
extractReqHeaderParams r
req.headers
            reqBody :: Maybe Schema
reqBody =
                if StdMethod
stdMeth StdMethod -> [StdMethod] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [StdMethod
HTTP.GET, StdMethod
HTTP.HEAD]
                    then Tree Body i o -> Maybe Schema
forall i o. Tree Body i o -> Maybe Schema
extractReqBodySchema r
req.body
                    else Maybe Schema
forall a. Maybe a
Nothing
            allDefs :: Definitions Schema
allDefs =
                Tree Body i o -> Definitions Schema
forall i o. Tree Body i o -> Definitions Schema
extractReqBodyDefs r
req.body
                    Definitions Schema -> Definitions Schema -> Definitions Schema
forall a. Semigroup a => a -> a -> a
<> (ResInfo -> Definitions Schema) -> [ResInfo] -> Definitions Schema
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ResInfo -> Definitions Schema
resBodyDefs [ResInfo]
resInfos
            op :: Operation
op =
                Operation
forall a. Monoid a => a
mempty
                    Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  Operation
  Operation
  [Referenced Param]
  [Referenced Param]
#parameters Optic
  A_Lens
  NoIx
  Operation
  Operation
  [Referenced Param]
  [Referenced Param]
-> [Referenced Param] -> Operation -> Operation
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ (Param -> Referenced Param) -> [Param] -> [Referenced Param]
forall a b. (a -> b) -> [a] -> [b]
map Param -> Referenced Param
forall a. a -> Referenced a
Inline ([PathPiece] -> [Param]
pathOAParams [PathPiece]
pieces [Param] -> [Param] -> [Param]
forall a. [a] -> [a] -> [a]
++ [Param]
qParams [Param] -> [Param] -> [Param]
forall a. [a] -> [a] -> [a]
++ [Param]
hParams)
                    Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& Optic A_Lens NoIx Operation Operation Responses Responses
#responses Optic A_Lens NoIx Operation Operation Responses Responses
-> Responses -> Operation -> Operation
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Maybe (Referenced Response)
-> InsOrdHashMap Int (Referenced Response) -> Responses
OA.Responses Maybe (Referenced Response)
forall a. Maybe a
Nothing
                        ( [(Int, Referenced Response)]
-> InsOrdHashMap Int (Referenced Response)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
IHM.fromList
                            [ (Status -> Int
HTTP.statusCode (ResInfo -> Status
resStatus ResInfo
ri), Response -> Referenced Response
forall a. a -> Referenced a
Inline (ResInfo -> Response
mkResResponse ResInfo
ri))
                            | ResInfo
ri <- [ResInfo]
resInfos
                            ]
                        )
                    Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& Maybe ByteString -> Maybe Schema -> Operation -> Operation
applyReqBodySchema (Tree Headers i o -> Maybe ByteString
forall i o. Tree Headers i o -> Maybe ByteString
extractReqContentType r
req.headers) Maybe Schema
reqBody
         in
            a
forall a. Monoid a => a
mempty
                a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& Optic k NoIx a a u v
#info Optic k NoIx a a u v
-> Optic l NoIx u v a b -> Optic k NoIx a a a b
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic l NoIx u v a b
#title Optic k NoIx a a a b -> b -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ b
"API"
                a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& Optic k NoIx a a u v
#info Optic k NoIx a a u v
-> Optic l NoIx u v a b -> Optic k NoIx a a a b
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic l NoIx u v a b
#version Optic k NoIx a a a b -> b -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ b
"0.1.0"
                a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
& Optic k NoIx a a u v
#components Optic k NoIx a a u v
-> Optic l NoIx u v a (Definitions Schema)
-> Optic k NoIx a a a (Definitions Schema)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic l NoIx u v a (Definitions Schema)
#schemas Optic k NoIx a a a (Definitions Schema)
-> Definitions Schema -> a -> a
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ Definitions Schema
allDefs
                a -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
& Optic k NoIx a b a (InsOrdHashMap FilePath PathItem)
#paths Optic k NoIx a b a (InsOrdHashMap FilePath PathItem)
-> InsOrdHashMap FilePath PathItem -> a -> b
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ FilePath -> PathItem -> InsOrdHashMap FilePath PathItem
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
IHM.singleton ([PathPiece] -> FilePath
pathTemplate [PathPiece]
pieces) (StdMethod -> Operation -> PathItem -> PathItem
setMethod StdMethod
stdMeth Operation
op PathItem
forall a. Monoid a => a
mempty)

class GenericOAPI (epF :: Type -> Type) where
    gOpenApi :: epF () -> OpenApi

instance GenericOAPI epF => GenericOAPI (D1 dm epF) where
    gOpenApi :: D1 dm epF () -> OpenApi
gOpenApi (M1 epF ()
ep) = forall (epF :: * -> *). GenericOAPI epF => epF () -> OpenApi
gOpenApi @epF epF ()
ep

instance GenericOAPI epF => GenericOAPI (C1 cm epF) where
    gOpenApi :: C1 cm epF () -> OpenApi
gOpenApi (M1 epF ()
ep) = forall (epF :: * -> *). GenericOAPI epF => epF () -> OpenApi
gOpenApi @epF epF ()
ep

instance (GenericOAPI epL, GenericOAPI epR) => GenericOAPI (epL :*: epR) where
    gOpenApi :: (:*:) epL epR () -> OpenApi
gOpenApi (epL ()
epL :*: epR ()
epR) = forall (epF :: * -> *). GenericOAPI epF => epF () -> OpenApi
gOpenApi @epL epL ()
epL OpenApi -> OpenApi -> OpenApi
forall a. Semigroup a => a -> a -> a
<> forall (epF :: * -> *). GenericOAPI epF => epF () -> OpenApi
gOpenApi @epR epR ()
epR

instance GenericOAPI (S1 sm (Rec0 (Forest (Shape method path query headers body result)))) where
    gOpenApi :: S1
  sm (Rec0 (Forest (Shape method path query headers body result))) ()
-> OpenApi
gOpenApi (M1 (K1 Forest (Shape method path query headers body result)
ep)) = Forest (Shape method path query headers body result) -> OpenApi
forall method path query headers body result.
Forest (Shape method path query headers body result) -> OpenApi
endpointToOpenApi Forest (Shape method path query headers body result)
ep

openApi ::
    forall server.
    ( Generic (server Forest)
    , GenericOAPI (Rep (server Forest))
    ) =>
    server Forest ->
    OpenApi
openApi :: forall (server :: (* -> *) -> *).
(Generic (server Forest), GenericOAPI (Rep (server Forest))) =>
server Forest -> OpenApi
openApi = forall (epF :: * -> *). GenericOAPI epF => epF () -> OpenApi
gOpenApi @(Rep (server Forest)) (Rep (server Forest) () -> OpenApi)
-> (server Forest -> Rep (server Forest) ())
-> server Forest
-> OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. server Forest -> Rep (server Forest) ()
forall x. server Forest -> Rep (server Forest) x
forall a x. Generic a => a -> Rep a x
from