{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module OpenAPI.Generate.Internal.Operation
( getResponseObject,
getResponseSchema,
defineOperationFunction,
getParameterDescription,
getParameterType,
getParametersTypeForSignature,
getParametersTypeForSignatureWithMonadTransformer,
getOperationName,
getOperationDescription,
getParametersFromOperationConcrete,
getBodySchemaFromOperation,
generateParameterizedRequestPath,
generateQueryParams,
RequestBodyDefinition (..),
)
where
import Control.Monad
import qualified Control.Monad.Reader as MR
import qualified Data.ByteString.Char8 as B8
import qualified Data.Char as Char
import qualified Data.List.Split as Split
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.PprLib hiding ((<>))
import qualified Network.HTTP.Simple as HS
import qualified Network.HTTP.Types as HT
import qualified OpenAPI.Common as OC
import qualified OpenAPI.Generate.Doc as Doc
import qualified OpenAPI.Generate.Flags as OAF
import OpenAPI.Generate.Internal.Util
import qualified OpenAPI.Generate.Model as Model
import qualified OpenAPI.Generate.Monad as OAM
import qualified OpenAPI.Generate.Types as OAT
import qualified OpenAPI.Generate.Types.Schema as OAS
data RequestBodyDefinition
= RequestBodyDefinition
{ schema :: OAT.Schema,
encoding :: OC.RequestBodyEncoding,
required :: Bool
}
getParametersFromOperationReference :: OAT.OperationObject -> [OAT.Referencable OAT.ParameterObject]
getParametersFromOperationReference = OAT.parameters
getSchemaFromParameterInner :: OAT.ParameterObject -> OAT.ParameterObjectSchema
getSchemaFromParameterInner = OAT.schema
getRequiredFromParameter :: OAT.ParameterObject -> Bool
getRequiredFromParameter = OAT.required
getInFromParameterObject :: OAT.ParameterObject -> OAT.ParameterObjectLocation
getInFromParameterObject = OAT.in'
getParametersFromOperationConcrete :: OAT.OperationObject -> OAM.Generator [OAT.ParameterObject]
getParametersFromOperationConcrete =
OAM.nested "parameters"
. fmap Maybe.catMaybes
. mapM
( \case
OAT.Concrete p -> pure $ Just p
OAT.Reference ref -> do
p <- OAM.getParameterReferenceM ref
if Maybe.isJust p
then pure p
else do
OAM.logWarning $ "Reference " <> ref <> " to ParameterObject could not be found and therefore will be skipped."
pure p
)
. getParametersFromOperationReference
getSchemaFromParameterOuter :: OAT.ParameterObjectSchema -> OAS.SchemaObject
getSchemaFromParameterOuter OAT.SimpleParameterObjectSchema {..} = case schema of
OAT.Concrete e -> e
_ -> error "not yet implemented"
getSchemaFromParameterOuter _ = error "not yet implemented"
getSchemaFromParameter :: OAT.ParameterObject -> OAS.SchemaObject
getSchemaFromParameter = getSchemaFromParameterOuter . getSchemaFromParameterInner
getNameFromParameter :: OAT.ParameterObject -> Text
getNameFromParameter = OAT.name
getParametersTypeForSignature :: [Q Type] -> Name -> Name -> Name -> Q Type
getParametersTypeForSignature types responseTypeName monadName securitySchemeName =
createFunctionType
( [t|OC.Configuration $(varT securitySchemeName)|]
: types
<> [[t|$(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]]
)
getParametersTypeForSignatureWithMonadTransformer :: [Q Type] -> Name -> Name -> Name -> Q Type
getParametersTypeForSignatureWithMonadTransformer types responseTypeName monadName securitySchemeName =
createFunctionType
( types
<> [[t|MR.ReaderT (OC.Configuration $(varT securitySchemeName)) $(varT monadName) (Either HS.HttpException (HS.Response $(varT responseTypeName)))|]]
)
createFunctionType :: [Q Type] -> Q Type
createFunctionType =
foldr1
(\t1 t2 -> [t|$t1 -> $t2|])
getParameterName :: OAT.ParameterObject -> OAM.Generator Name
getParameterName parameter = haskellifyNameM False $ getNameFromParameter parameter
getParameterType :: OAF.Flags -> OAT.ParameterObject -> Q Type
getParameterType flags parameter =
let paramType = varT $ Model.getSchemaType flags (getSchemaFromParameter parameter)
in ( if getRequiredFromParameter parameter
then paramType
else [t|Maybe $(paramType)|]
)
getParameterDescription :: OAT.ParameterObject -> OAM.Generator Text
getParameterDescription parameter = do
schema <- Model.resolveSchemaReferenceWithoutWarning $ OAT.schema (OAT.schema (parameter :: OAT.ParameterObject) :: OAT.ParameterObjectSchema)
let name = OAT.name (parameter :: OAT.ParameterObject)
description = maybe "" (": " <>) $ OAT.description (parameter :: OAT.ParameterObject)
constraints = joinWith ", " $ Model.getConstraintDescriptionsOfSchema schema
pure $ Doc.escapeText $ name <> description <> (if T.null constraints then "" else " | Constraints: " <> constraints)
defineOperationFunction ::
Bool ->
Name ->
[OAT.ParameterObject] ->
Text ->
Text ->
Maybe RequestBodyDefinition ->
Q Exp ->
OAM.Generator (Q Doc)
defineOperationFunction useExplicitConfiguration fnName params requestPath method bodySchema responseTransformerExp = do
paramVarNames <- mapM getParameterName params
let configArg = mkName "config"
paraPattern = varP <$> paramVarNames
fnPatterns = if useExplicitConfiguration then varP configArg : paraPattern else paraPattern
namedParameters = zip paramVarNames params
namedPathParameters = filter ((== OAT.PathParameterObjectLocation) . getInFromParameterObject . snd) namedParameters
request = generateParameterizedRequestPath namedPathParameters requestPath
namedQueryParameters = filter ((== OAT.QueryParameterObjectLocation) . getInFromParameterObject . snd) namedParameters
queryParameters = generateQueryParams namedQueryParameters
bodyName = mkName "body"
strMethod = T.unpack method
pure $
ppr <$> case bodySchema of
Just RequestBodyDefinition {..} ->
let encodeExpr =
varE $
case encoding of
OC.RequestBodyEncodingFormData -> 'OC.RequestBodyEncodingFormData
OC.RequestBodyEncodingJSON -> 'OC.RequestBodyEncodingJSON
in [d|
$(conP fnName $ fnPatterns <> [varP bodyName]) =
$responseTransformerExp
( $( if useExplicitConfiguration
then [|OC.doBodyCallWithConfiguration $(varE configArg)|]
else [|OC.doBodyCallWithConfigurationM|]
)
(T.toUpper $ T.pack strMethod)
(T.pack $(request))
$(queryParameters)
$(if required then [|Just $(varE bodyName)|] else varE bodyName)
$(encodeExpr)
)
|]
Nothing ->
[d|
$(conP fnName fnPatterns) =
$responseTransformerExp
( $( if useExplicitConfiguration
then [|OC.doCallWithConfiguration $(varE configArg)|]
else [|OC.doCallWithConfigurationM|]
)
(T.toUpper $ T.pack strMethod)
(T.pack $(request))
$(queryParameters)
)
|]
getBodySchemaFromOperation :: OAT.OperationObject -> OAM.Generator (Maybe RequestBodyDefinition)
getBodySchemaFromOperation operation = do
requestBody <- getRequestBodyObject operation
case requestBody of
Just body -> getRequestBodySchema body
Nothing -> pure Nothing
getRequestBodyContent :: OAT.RequestBodyObject -> Map.Map Text OAT.MediaTypeObject
getRequestBodyContent = OAT.content
getSchemaFromMedia :: OAT.MediaTypeObject -> Maybe OAT.Schema
getSchemaFromMedia = OAT.schema
getRequestBodySchema :: OAT.RequestBodyObject -> OAM.Generator (Maybe RequestBodyDefinition)
getRequestBodySchema body =
let content = Map.lookup "application/json" $ getRequestBodyContent body
createRequestBodyDefinition encoding schema =
Just $
RequestBodyDefinition
{ schema = schema,
encoding = encoding,
required = OAT.required (body :: OAT.RequestBodyObject)
}
in case content of
Nothing ->
let formContent = Map.lookup "application/x-www-form-urlencoded" $ getRequestBodyContent body
in case formContent of
Nothing -> do
OAM.logWarning "Only content type application/json and application/x-www-form-urlencoded is supported"
pure Nothing
Just media ->
pure $
getSchemaFromMedia media
>>= createRequestBodyDefinition OC.RequestBodyEncodingFormData
Just media ->
pure $
getSchemaFromMedia media
>>= createRequestBodyDefinition OC.RequestBodyEncodingJSON
getRequestBodyObject :: OAT.OperationObject -> OAM.Generator (Maybe OAT.RequestBodyObject)
getRequestBodyObject operation =
case OAT.requestBody operation of
Nothing -> pure Nothing
Just (OAT.Concrete p) -> pure $ Just p
Just (OAT.Reference ref) -> do
p <- OAM.getRequestBodyReferenceM ref
when (Maybe.isNothing p) $ OAM.logWarning $ "Reference " <> ref <> " to RequestBody could not be found and therefore will be skipped."
pure p
getResponseSchema :: OAT.ResponseObject -> OAM.Generator (Maybe OAT.Schema)
getResponseSchema response = do
let contentMap = OAT.content (response :: OAT.ResponseObject)
schema = Map.lookup "application/json" contentMap >>= getSchemaFromMedia
when (Maybe.isNothing schema && not (Map.null contentMap)) $ OAM.logWarning "Only content type application/json is supported for response bodies."
pure schema
getResponseObject :: OAT.Referencable OAT.ResponseObject -> OAM.Generator (Maybe OAT.ResponseObject)
getResponseObject (OAT.Concrete p) = pure $ Just p
getResponseObject (OAT.Reference ref) = do
p <- OAM.getResponseReferenceM ref
when (Maybe.isNothing p) $ OAM.logWarning $ "Reference " <> ref <> " to response could not be found and therefore will be skipped."
pure p
generateQueryParams :: [(Name, OAT.ParameterObject)] -> Q Exp
generateQueryParams ((name, param) : xs) =
infixE (Just [|(T.pack queryName, $(expr))|]) (varE $ mkName ":") (Just $ generateQueryParams xs)
where
queryName = T.unpack $ getNameFromParameter param
required = getRequiredFromParameter param
expr =
if required
then [|$(varE $ mkName "GHC.Base.Just") $ OC.stringifyModel $(varE name)|]
else [|OC.stringifyModel <$> $(varE name)|]
generateQueryParams _ = [|[]|]
generateParameterizedRequestPath :: [(Name, OAT.ParameterObject)] -> Text -> Q Exp
generateParameterizedRequestPath ((paramName, param) : xs) path =
foldr1 (foldingFn paramName) partExpressiones
where
parts = Split.splitOn ("{" <> T.unpack (getNameFromParameter param) <> "}") (T.unpack path)
partExpressiones = generateParameterizedRequestPath xs . T.pack <$> parts
foldingFn :: Name -> Q Exp -> Q Exp -> Q Exp
foldingFn var a b = [|$(a) ++ B8.unpack (HT.urlEncode True $ B8.pack $ OC.stringifyModel $(varE var)) ++ $(b)|]
generateParameterizedRequestPath _ path = litE (stringL $ T.unpack path)
getOperationDescription :: OAT.OperationObject -> Text
getOperationDescription operation =
Maybe.fromMaybe "" $ Maybe.listToMaybe $
Maybe.catMaybes
[ OAT.description (operation :: OAT.OperationObject),
OAT.summary (operation :: OAT.OperationObject)
]
getOperationName :: Text -> Text -> OAT.OperationObject -> OAM.Generator Name
getOperationName requestPath method operation =
let operationId = OAT.operationId operation
textName = Maybe.fromMaybe (T.map Char.toLower method <> requestPath) operationId
in haskellifyNameM False textName