{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module OpenAPI.Generate.Response
( getResponseDefinitions,
)
where
import qualified Data.Aeson as Aeson
import qualified Data.Either as Either
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH
import Language.Haskell.TH.PprLib hiding ((<>))
import Language.Haskell.TH.Syntax
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Types as HT
import qualified OpenAPI.Generate.Doc as Doc
import qualified OpenAPI.Generate.Flags as OAF
import OpenAPI.Generate.Internal.Operation
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
getResponseDefinitions ::
OAT.OperationObject ->
(Text -> Text) ->
OAM.Generator (Name, Q Exp, Q Doc)
getResponseDefinitions operation appendToOperationName = do
convertToCamelCase <- OAM.getFlag OAF.optConvertToCamelCase
responseSuffix <- OAM.getFlag $ T.pack . OAF.optResponseTypeSuffix
responseBodySuffix <- OAM.getFlag $ T.pack . OAF.optResponseBodyTypeSuffix
let responsesObject = OAT.responses (operation :: OAT.OperationObject)
createBodyName = createResponseNameAsText convertToCamelCase appendToOperationName . (responseBodySuffix <>)
createName = createResponseName convertToCamelCase appendToOperationName . (responseSuffix <>)
responseName = createName ""
responseReferenceCases = getStatusCodeResponseCases responsesObject <> getRangeResponseCases responsesObject
responseCases <- resolveResponseReferences responseReferenceCases
let responseDescriptions = getResponseDescription . (\(_, _, r) -> r) <$> responseCases
schemas <- generateResponseCaseDefinitions createBodyName responseCases
pure $ (responseName,createResponseTransformerFn createName schemas,) $
vcat
<$> sequence
[ pure $
Doc.generateHaddockComment
[ "Represents a response of the operation '" <> appendToOperationName "" <> "'.",
"",
"The response constructor is chosen by the status code of the response. If no case matches (no specific case for the response code, no range case, no default case), '"
<> createResponseNameAsText convertToCamelCase appendToOperationName (responseSuffix <> errorSuffix)
<> "' is used."
],
( `Doc.sideBySide`
(text "" $$ Doc.sideComments ("Means either no matching case available or a parse error" : responseDescriptions))
)
. Doc.breakOnTokensWithReplacement
( \case
"=" -> "=\n "
token -> "\n " <> token
)
["=", "deriving", "|"]
. ppr
<$> dataD
(cxt [])
responseName
[]
Nothing
( fmap
( \(suffix, _, maybeSchema) ->
normalC
(createName suffix)
( case maybeSchema of
Just (type', _) -> [bangType (bang noSourceUnpackedness noSourceStrictness) type']
Nothing -> []
)
)
((errorSuffix, [||const True||], Just ([t|String|], (Doc.emptyDoc, Set.empty))) : schemas)
)
[derivClause Nothing [conT ''Show, conT ''Eq]],
printSchemaDefinitions schemas
]
type ResponseReferenceCase = (Text, TExpQ (HT.Status -> Bool), OAT.Referencable OAT.ResponseObject)
type ResponseCase = (Text, TExpQ (HT.Status -> Bool), OAT.ResponseObject)
type ResponseCaseDefinition = (Text, TExpQ (HT.Status -> Bool), Maybe Model.TypeWithDeclaration)
errorSuffix :: Text
errorSuffix = "Error"
createResponseNameAsText :: Bool -> (Text -> Text) -> Text -> Text
createResponseNameAsText convertToCamelCase appendToOperationName = T.pack . haskellifyText convertToCamelCase True . appendToOperationName
createResponseName :: Bool -> (Text -> Text) -> Text -> Name
createResponseName convertToCamelCase appendToOperationName = mkName . T.unpack . createResponseNameAsText convertToCamelCase appendToOperationName
getRangeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase]
getRangeResponseCases responsesObject =
Maybe.catMaybes
[ ("1XX",[||HT.statusIsInformational||],) <$> OAT.range1XX responsesObject,
("2XX",[||HT.statusIsSuccessful||],) <$> OAT.range2XX responsesObject,
("3XX",[||HT.statusIsRedirection||],) <$> OAT.range3XX responsesObject,
("4XX",[||HT.statusIsClientError||],) <$> OAT.range4XX responsesObject,
("5XX",[||HT.statusIsServerError||],) <$> OAT.range5XX responsesObject,
("Default",[||const True||],) <$> OAT.default' (responsesObject :: OAT.ResponsesObject)
]
getStatusCodeResponseCases :: OAT.ResponsesObject -> [ResponseReferenceCase]
getStatusCodeResponseCases =
fmap (\(code, response) -> (T.pack $ show code, [||\status -> HT.statusCode status == code||], response))
. Map.toList
. OAT.perStatusCode
resolveResponseReferences :: [ResponseReferenceCase] -> OAM.Generator [ResponseCase]
resolveResponseReferences =
fmap Maybe.catMaybes
. mapM
( \(suffix, guard, response) ->
fmap (suffix,guard,) <$> OAM.nested suffix (getResponseObject response)
)
generateResponseCaseDefinitions :: (Text -> Text) -> [ResponseCase] -> OAM.Generator [ResponseCaseDefinition]
generateResponseCaseDefinitions createBodyName =
mapM
( \(suffix, guard, r) -> OAM.nested suffix $ do
responseSchema <- getResponseSchema r
(suffix,guard,) <$> mapM (Model.defineModelForSchemaNamed $ createBodyName suffix) responseSchema
)
printSchemaDefinitions :: [ResponseCaseDefinition] -> Q Doc
printSchemaDefinitions =
fmap vcat
. sequence
. Maybe.mapMaybe (\(_, _, namedTypeDef) -> fmap (fst . snd) namedTypeDef)
createResponseTransformerFn :: (Text -> Name) -> [ResponseCaseDefinition] -> Q Exp
createResponseTransformerFn createName schemas =
let responseArgName = mkName "response"
bodyName = mkName "body"
ifCases =
multiIfE $
fmap
( \(suffix, guard, maybeSchema) ->
normalGE
[|$(unTypeQ guard) (HC.responseStatus $(varE responseArgName))|]
( case maybeSchema of
Just (type', _) -> [|$(varE $ createName suffix) <$> (Aeson.eitherDecodeStrict $(varE bodyName) :: Either String $type')|]
Nothing -> [|Right $(varE $ createName suffix)|]
)
)
schemas
<> [normalGE [|otherwise|] [|Left "Missing default response type"|]]
transformLambda = lamE [varP responseArgName, varP bodyName] ifCases
in [|fmap (fmap (\response -> fmap (Either.either $(varE $ createName errorSuffix) id . $transformLambda response) response))|]
getResponseDescription :: OAT.ResponseObject -> Text
getResponseDescription response = Doc.escapeText $ OAT.description (response :: OAT.ResponseObject)