unit XData.OpenApi.Builder;

{$I XData.inc}

interface

uses
  System.IOUtils, System.SysUtils, System.TypInfo, Generics.Collections, System.Classes,
  System.Rtti, Generics.Defaults,
  OpenAPI.Document,
  OpenAPI.Classes,
  OpenAPI.Classes.Parameter,
  OpenAPI.Classes.Path,
  OpenAPI.Classes.Operation,
  OpenAPI.Classes.Security,
  OpenAPI.Types,
  XData.Aurelius.Model,
  XData.Consts,
  XData.JSchema.Classes,
  XData.JSchema.Builder,
  XData.JSchema.Generators,
  XData.Model.Classes,
  XData.Server.Module,
  XData.Service.Common;

type
  TOpenApiBuilder = class
  private const
    SuccessfulResponse = 'Successful response';
    NotFoundResponse = 'Entity not found';
  private
    FModule: TXDataServerModule;
    FModel: TXDataAureliusModel;
    FRtti: TRttiContext;
    FDocument: TOpenApiDocument;
    FExcludeOperations: Boolean;
    FExcludeEntities: Boolean;
    FJwtSecurity: Boolean;
    FEnableKeyAsSegment: Boolean;
    function BuildSchema(const ATypeToken: TTypeToken): TJsonSchema;
    function ListSchema(const ATypeToken: TTypeToken): TJsonSchema;
    procedure ProcessSchemaDoc(Schema: TObjectSchema; EntityType: TXDataEntityType);
    procedure SetSchemaDefaultValue(Schema: TJsonSchema; const Value: TValue);
  private
    procedure BuildFromAction(Action: TXDataAction);
    procedure AddActionUriParam(Operation: TOperation; ParamDef: TXDataParamDef);
    function ActionInputSchema(Action: TXDataAction): TJsonSchema;
    function ActionOutputSchema(Action: TXDataAction): TJsonSchema;
    function ActionSingleObjectResult(Action: TXDataAction): Boolean;
    function ActionResultCanExpand(Action: TXDataAction): Boolean;
    function IncludeAction(Action: TXDataAction): Boolean;
    function IncludeEntitySet(EntitySet: TXDataEntitySet): Boolean;
  private
    FEnableKeyInParenthesis: Boolean;
    procedure BuildFromEntitySet(EntitySet: TXDataEntitySet);
    procedure BuildSingleEntityOperations(EntitySet: TXDataEntitySet; Path: TPathItem;
      KeyProps: TXDataSimplePropertyArray; KeyNames: TArray<string>; const OperationSuffix: string = '');
    procedure AddCriteriaParameters(Operation: TOperation);
    procedure AddKeyParameters(Operation: TOperation; KeyNames: TArray<string>;
      KeyProps: TXDataSimplePropertyArray);
  public
    constructor Create(AModule: TXDataServerModule);
    procedure Build;
    function GetDocument: TOpenApiDocument;
    property Document: TOpenApiDocument read FDocument;
    property Model: TXDataAureliusModel read FModel;
    property ExcludeOperations: Boolean read FExcludeOperations write FExcludeOperations;
    property ExcludeEntities: Boolean read FExcludeEntities write FExcludeEntities;
    property JwtSecurity: Boolean read FJwtSecurity write FJwtSecurity;
    property EnableKeyAsSegment: Boolean read FEnableKeyAsSegment write FEnableKeyAsSegment;
    property EnableKeyInParenthesis: Boolean read FEnableKeyInParenthesis write FEnableKeyInParenthesis;
  end;

implementation

uses
  Bcl.Rtti.Utils;

{ TOpenApiBuilder }

function TOpenApiBuilder.GetDocument: TOpenApiDocument;
begin
  FDocument := TOpenApiDocument.Create;
  try
    Build;
  except
    FDocument.Free;
    raise;
  end;
  Result := FDocument;
end;

function TOpenApiBuilder.IncludeAction(Action: TXDataAction): Boolean;
var
  RttiType: TRttiType;
begin
  RttiType := FRtti.GetType(FModel.GetControllerInfo(Action.Controller).InterfaceType);
  if (RttiType <> nil) and (TRttiUtils.GetInstance.GetAttribute(RttiType, SwaggerExcludeAttribute) <> nil) then
    Exit(False);

  Result := TRttiUtils.GetInstance.GetAttribute(Model.GetActionInfo(Action).Method, SwaggerExcludeAttribute) = nil;
end;

function TOpenApiBuilder.IncludeEntitySet(EntitySet: TXDataEntitySet): Boolean;
begin
  Result := True;
end;

function TOpenApiBuilder.ListSchema(const ATypeToken: TTypeToken): TJsonSchema;
var
  Schema: TObjectSchema;
begin
  Schema := TObjectSchema.Create;
  try
    Schema.Properties[JsonResultValue] := BuildSchema(ATypeToken);
  except
    Schema.Free;
    raise;
  end;
  Result := Schema;
end;

procedure TOpenApiBuilder.ProcessSchemaDoc(Schema: TObjectSchema;
  EntityType: TXDataEntityType);
var
  Prop: TXDataProperty;
  Pair: TPair<string, TJsonSchema>;
begin
  Schema.Description := EntityType.Description;
  for Pair in Schema.Properties do
  begin
    Prop := EntityType.FindAnyProperty(Pair.Key);
    if Prop <> nil then
      Pair.Value.Description := Prop.Description;
  end;
end;

procedure TOpenApiBuilder.SetSchemaDefaultValue(Schema: TJsonSchema; const Value: TValue);
var
  StrValue: string;
  NumValue: Double;
begin
  if (Schema is TStringSchema) and Value.TryAsType<string>(StrValue) then
    TStringSchema(Schema).DefaultValue := StrValue
  else
  if (Schema is TNumericSchema) and Value.TryAsType<Double>(NumValue) then
    TNumericSchema(Schema).DefaultValue := NumValue;
end;

function TOpenApiBuilder.ActionResultCanExpand(Action: TXDataAction): Boolean;
var
  AClass: TClass;
begin
  Result := False;
  if Action.IsResultSingleObject then
  begin
    AClass := Model.GetActionInfo(Action).ReturnType.AsInstance.MetaclassType;
    if Model.Explorer.IsObjectList(AClass) then
      AClass := TRttiUtils.GetInstance.GetSurroundedClass(AClass);
    Result := Assigned(Model.FindEntityTypeByClass(AClass));
  end;
end;

function TOpenApiBuilder.ActionInputSchema(Action: TXDataAction): TJsonSchema;
var
  Schema: TObjectSchema;
  PropSchema: TJsonSchema;
  ParamDef: TXDataParamDef;
begin
  // Obs: see XData.Payload.Json.Reader -> TJsonResultReader.ReadParams
  // and XData.Server.Module.ExecuteAction and XData.Client.OnInvoke
  if (Action.BodyParamCount = 1) and Action.BodyParams[0].RttiType.IsInstance then
    Result := BuildSchema(Action.BodyParams[0].RttiType.Handle)
  else
  begin
    Schema := TObjectSchema.Create;
    try
      for ParamDef in Action.Parameters do
        if (ParamDef.BindingMode = TBindingMode.FromBody) and ParamDef.Input then
        begin
          PropSchema := BuildSchema(ParamDef.RttiType.Handle);
          Schema.Properties[ParamDef.Name] := PropSchema;
          PropSchema.Description := ParamDef.Description;

          // Handle default value
          if not ParamDef.DefaultValue.IsEmpty then
            SetSchemaDefaultValue(Schema, ParamDef.DefaultValue)
          else
            Schema.Required.Add(ParamDef.Name);
        end;
    except
      Schema.Free;
      raise;
    end;
    Result := Schema;
  end;
end;

function TOpenApiBuilder.ActionOutputSchema(Action: TXDataAction): TJsonSchema;
var
  Schema: TObjectSchema;
  ParamDef: TXDataParamDef;
  ReturnType: TRttiType;
begin
  // Obs: see XData.Payload.Json.Writer -> TJsonResultWriter.WriteResult
  // and XData.Server.Module.ExecuteAction and XData.Client.OnInvoke
  ReturnType := Model.GetActionInfo(Action).ReturnType;
  if ActionSingleObjectResult(Action) then
    Result := BuildSchema(ReturnType.Handle)
  else
  begin
    Schema := TObjectSchema.Create;
    try
      // Property that contains return type
      if ReturnType <> nil then
      begin
        if Action.HasOutputParams then
          Schema.Properties[JsonResultParam] := BuildSchema(ReturnType.Handle)
        else
          Schema.Properties[JsonResultValue] := BuildSchema(ReturnType.Handle);
      end;

      // Parameters passed by reference
      for ParamDef in Action.Parameters do
        if ParamDef.Output then
        begin
          Schema.Properties[ParamDef.Name] := BuildSchema(ParamDef.RttiType.Handle);
          Schema.Properties[ParamDef.Name].Description := ParamDef.Description;
        end;
    except
      Schema.Free;
      raise;
    end;
    Result := Schema;
  end;
end;

function TOpenApiBuilder.ActionSingleObjectResult(
  Action: TXDataAction): Boolean;
begin
  Result := Action.IsResultSingleObject and not
    Model.Explorer.IsValueList(Model.GetActionInfo(Action).ReturnType.AsInstance.MetaclassType);
end;

procedure TOpenApiBuilder.AddActionUriParam(Operation: TOperation; ParamDef: TXDataParamDef);
var
  Param: TParameter;
  I: Integer;
  StructuredType: TXDataStructuredType;
  Prop: TXDataScalarProperty;
  PropInfo: TXDataAureliusPropInfo;
begin
  // Special case for structured types - each property becomes a parameter
  if ParamDef.ParamType is TXDataStructuredType then
  begin
    StructuredType := TXDataStructuredType(ParamDef.ParamType);
    for I := 0 to StructuredType.ScalarPropertyCount - 1 do
    begin
      Prop := StructuredType.GetScalarProperty(I);
      PropInfo := Model.GetScalarPropertyInfo(Prop);
      Operation.AddParameter(Prop.Name, TLocation.Query,
        BuildSchema(PropInfo.RttiInfo.RealType.Handle), Prop.Description, False);
    end;
  end
  else
  begin
    Param := Operation.AddParameter(ParamDef.Name, TLocation.Query,
      BuildSchema(ParamDef.RttiType.Handle), ParamDef.Description, ParamDef.Input);

    // Handle default value
    if not ParamDef.DefaultValue.IsEmpty then
    begin
      Param.Required := False;
      SetSchemaDefaultValue(Param.Schema, ParamDef.DefaultValue);
    end;
  end;
end;

procedure TOpenApiBuilder.AddCriteriaParameters(Operation: TOperation);
begin
  Operation.AddParameter('$filter', TLocation.Query, TStringSchema.Create);
  Operation.AddParameter('$orderby', TLocation.Query, TStringSchema.Create);
  Operation.AddParameter('$top', TLocation.Query, TIntegerSchema.Create);
  Operation.AddParameter('$skip', TLocation.Query, TIntegerSchema.Create);
  Operation.AddParameter('$expand', TLocation.Query, TStringSchema.Create);
end;

procedure TOpenApiBuilder.AddKeyParameters(Operation: TOperation; KeyNames:
  TArray<string>; KeyProps: TXDataSimplePropertyArray);
var
  I: Integer;
  KeyProp: TXDataSimpleProperty;
begin
  for I := 0 to Length(KeyProps) - 1 do
  begin
    KeyProp := KeyProps[I];
    Operation.AddParameter(KeyNames[I], TLocation.Path,
      BuildSchema(Model.GetPropertyInfo(KeyProp).RttiInfo.RealType.Handle),
      '', True);
  end;
end;

procedure TOpenApiBuilder.Build;
var
  Schema: TXDataSchema;
  Controller: TXDataController;
  Action: TXDataAction;
  EntitySet: TXDataEntitySet;
  Sec: TSecurityDefinition;
  Req: TSecurityRequirement;
begin
//  Document.Info.Title := 'XDataSwaggerTest';
//  Document.Info.Version := '1.0';
//  Document.Host := 'localhost:2001';
//  Document.BasePath := '/tms/music';

  if JwtSecurity then
  begin
    Sec := TSecurityDefinition.Create;
    Sec.&Type := TSecuritySchemeType.ApiKey;
    Sec.Name := 'jwt';
    Sec.&In := TLocation.Header;
    Sec.Name := 'Authorization';
    Document.SecurityDefinitions.Add('jwt', Sec);

    Req := TSecurityRequirement.Create;
    Req.Add('jwt', TScopeNames.Create);
    Document.Security.Add(Req);
  end;

  for Schema in Model.Schemas do
  begin
    // Generate Service Operations
    if not ExcludeOperations then
      for Controller in Schema.Controllers do
        for Action in Controller.Actions do
          if IncludeAction(Action) then
            BuildFromAction(Action);

    // Generate Entities
    if not ExcludeEntities then
      for EntitySet in Model.DefaultEntityContainer.EntitySets do
        if IncludeEntitySet(EntitySet) then
          BuildFromEntitySet(EntitySet);
  end;

  // Sort tags by name
  Document.Tags.Sort(TComparer<TTag>.Construct(
    function(const A, B: TTag): Integer
      begin
        Result := CompareText(A.Name, B.Name);
      end
  ));
end;

procedure TOpenApiBuilder.BuildFromAction(Action: TXDataAction);
var
  Path: TPathItem;
  PathName: string;
  Operation: TOperation;
  ParamDef: TXDataParamDef;
  SegmentIndex: Integer;
  RouteInfo: TXDataRouteInfo;
  I: Integer;
  UsedParamValues: TArray<Boolean>;
  TagName: string;
begin
  PathName := '';
  RouteInfo := Action.RouteInfo;
  SetLength(UsedParamValues, Action.PathParamCount);
  for SegmentIndex := 0 to RouteInfo.SegmentCount - 1 do
  begin
    PathName := PathName + '/';
    if RouteInfo.Segments[SegmentIndex].IsParam then
    begin
      PathName := PathName + '{' + Action.PathParams[RouteInfo.Segments[SegmentIndex].ParamIndex].Name + '}';
      UsedParamValues[RouteInfo.Segments[SegmentIndex].ParamIndex] := True;
    end
    else
      PathName := PathName + RouteInfo.Segments[SegmentIndex].Value;
  end;
  for I := 0 to Action.PathParamCount - 1 do
    if not UsedParamValues[I] then
      PathName := PathName + '/{' + Action.PathParams[I].Name + '}';
  if PathName = '' then
    PathName := '/';

  // Create the path item for the action
  Path := Document.AddPath(PathName);
  Operation := Path.GetOperation(Action.HttpMethod);
  Operation.OperationId := Action.OperationId;
  TagName := Action.Controller.TagName;
  if (TagName = '') and (Action.Controller.RouteInfo2.SegmentCount > 0) then
    TagName := Action.Controller.RouteInfo2.Segments[Action.Controller.RouteInfo2.SegmentCount - 1].Value;
  if TagName <> '' then
  begin
    FDocument.AddTag(TagName, Action.Controller.Description);
    Operation.Tags.Add(TagName);
  end;

  // General info about the operation
  Operation.Summary := Action.Description;
  Operation.Description := Action.Remarks;

  if Action.BodyParamCount > 0 then
  begin
    if Action.IsParamStream then
    begin
      Operation.Consumes.Add(MultiPartFormDataMediaType);
      Operation.AddParameter('Input', TLocation.FormData, TFileSchema.Create);
    end
    else
    begin
      Operation.Consumes.Add(JsonMediaType);
      Operation.BodyParameter(ActionInputSchema(Action));
    end;
  end;

  // Create query parameters
  for ParamDef in Action.Parameters do
    case ParamDef.BindingMode of
      TBindingMode.FromURI:
        AddActionUriParam(Operation, ParamDef);
      TBindingMode.FromPath:
        Operation.AddParameter(ParamDef.Name, TLocation.Path,
          BuildSchema(ParamDef.RttiType.Handle), ParamDef.Description, ParamDef.Input);
    end;

  // Specify response type
  if Action.IsResultStream then
  begin
    Operation.Responses.Add('200', TResponse.Create(SuccessfulResponse, TFileSchema.Create));
  end
  else
  if Action.IsResultCriteria then
  begin
    Operation.Responses.Add('200', TResponse.Create(SuccessfulResponse, BuildSchema(TList<TObject>)));
  end
  else
  begin
    if (Model.GetActionInfo(Action).ReturnType <> nil) or Action.HasOutputParams then
    begin
      Operation.Produces.Add(JsonMediaType);
      Operation.Responses.Add('200', TResponse.Create(SuccessfulResponse, ActionOutputSchema(Action)));
      if ActionResultCanExpand(Action) then
        Operation.AddParameter('$expand', TLocation.Query, TStringSchema.Create);
    end
    else
      Operation.Responses.Add('204', TResponse.Create(SuccessfulResponse));
      //  if ActionSingleObjectResult(Action) then
      //    Operation.Responses.Add('404', TResponse.Create('Null object'));
  end;
end;

procedure TOpenApiBuilder.BuildFromEntitySet(EntitySet: TXDataEntitySet);
var
  Path: TPathItem;
  BasePath: string;
  EntityPath, EntityPath2: string;
  Operation: TOperation;
  Clazz: TClass;
  KeyProp: TXDataSimpleProperty;
  KeyProps: TXDataSimplePropertyArray;
  KeyNames: TArray<string>;
  I: Integer;
  Schema: TJsonSchema;
  TagName: string;
begin
  Clazz := Model.GetEntityTypeInfo(EntitySet.EntityType).Clazz;

  // Prepare tag
  TagName := EntitySet.TagName;
  if TagName = '' then
    TagName := EntitySet.Name;

  // Build path name
  BasePath := '/' + Model.EntitySetUrl(EntitySet);

  // Create path for entity set
  Path := Document.AddPath(BasePath);

  // ListEntities operation: GET operation on entity set
  if FModule.HasEndpoint(TEntitySetPermission.List, EntitySet) then
  begin
    FDocument.AddTag(TagName, EntitySet.Description);
    Operation := Path.Get;
    Operation.Tags.Add(TagName);
    Operation.OperationId := 'List' + EntitySet.Name;
    AddCriteriaParameters(Operation);
    Operation.Produces.Add(JsonMediaType);
    Operation.Responses.Add('200', TResponse.Create(SuccessfulResponse,
      ListSchema(TTypeToken.Create(TypeInfo(TList<TObject>), Clazz.ClassInfo))
    ));
  end;

  // CreateEntity operation: POST operation on entity set
  if FModule.HasEndpoint(TEntitySetPermission.Insert, EntitySet) then
  begin
    FDocument.AddTag(TagName, EntitySet.Description);
    Operation := Path.Post;
    Operation.Tags.Add(TagName);
    Operation.OperationId := 'Create' + EntitySet.Name;
    Operation.Consumes.Add(JsonMediaType);
    Operation.BodyParameter(BuildSchema(Clazz.ClassInfo));
    Operation.Produces.Add(JsonMediaType);
    // consider adding location header
    Operation.Responses.Add('201', TResponse.Create(SuccessfulResponse,
      BuildSchema(Clazz.ClassInfo)));
  end;

  { Now let's add operations related to a single entity. We need to change the path }

  // First find and define the id parameters
  KeyProps := EntitySet.EntityType.KeyScalarProperties;
  EntityPath := BasePath + '(';
  EntityPath2 := BasePath;
  SetLength(KeyNames, Length(KeyProps));
  for I := 0 to Length(KeyProps) - 1 do
  begin
    KeyProp := KeyProps[I];
    if I > 0 then
      EntityPath := EntityPath + ', ';
    EntityPath2 := EntityPath2 + '/';
    KeyNames[I] := KeyProp.Name;
    if KeyProp.Parent <> EntitySet.EntityType then
      KeyNames[I] := KeyProp.Parent.Name + '_' + KeyNames[I];
    EntityPath := EntityPath + '{' + KeyNames[I] + '}';
    EntityPath2 := EntityPath2 + '{' + KeyNames[I] + '}';
  end;
  EntityPath := EntityPath + ')';

  // Now create the path and add entiy operations to it
  if EnableKeyInParenthesis then
  begin
    Path := Document.AddPath(EntityPath);
    BuildSingleEntityOperations(EntitySet, Path, KeyProps, KeyNames);
  end;

  // if key as segment is enabled, then also add those
  if EnableKeyAsSegment then
  begin
    Path := Document.AddPath(EntityPath2);
    BuildSingleEntityOperations(EntitySet, Path, KeyProps, KeyNames, '_Path');
  end;

  // Load XML Doc for entity type
  if FDocument.Definitions.TryGetValue(Clazz.QualifiedClassName, Schema) then
    if Schema is TObjectSchema then
      ProcessSchemaDoc(TObjectSchema(Schema), EntitySet.EntityType);
//      ProcessSchemaDoc(TObjectSchema(Schema), Clazz);
end;

function TOpenApiBuilder.BuildSchema(const ATypeToken: TTypeToken): TJsonSchema;
var
  JSBuilder: TXDataJSchemaBuilder;
begin
  JSBuilder := TXDataJSchemaBuilder.Create(Model);
  try
    JSBuilder.Generators.Definitions := FDocument.Definitions;
    Result := JSBuilder.Generators.ProcessRef(ATypeToken);
  finally
    JSBuilder.Free;
  end;
end;

procedure TOpenApiBuilder.BuildSingleEntityOperations(EntitySet: TXDataEntitySet;
  Path: TPathItem; KeyProps: TXDataSimplePropertyArray; KeyNames: TArray<string>;
  const OperationSuffix: string = '');
var
  Operation: TOperation;
  Clazz: TClass;
  TagName: string;
begin
  TagName := EntitySet.TagName;
  if TagName = '' then
    TagName := EntitySet.Name;
  Clazz := Model.GetEntityTypeInfo(EntitySet.EntityType).Clazz;

  // RetrieveEntity operation: GET operation on entity
  if FModule.HasEndpoint(TEntitySetPermission.Get, EntitySet) then
  begin
    FDocument.AddTag(TagName, EntitySet.Description);
    Operation := Path.Get;
    Operation.Tags.Add(TagName);
    Operation.OperationId := 'Retrieve' + EntitySet.Name + OperationSuffix;
    AddKeyParameters(Operation, KeyNames, KeyProps);
    Operation.Produces.Add(JsonMediaType);
    Operation.Responses.Add('200', TResponse.Create(SuccessfulResponse,
      BuildSchema(Clazz.ClassInfo)));
    Operation.Responses.Add('404', TResponse.Create(NotFoundResponse, nil));
  end;

  // UpdateEntity operation: PUT operation on entity
  if FModule.HasEndpoint(TEntitySetPermission.Modify, EntitySet) then
  begin
    FDocument.AddTag(TagName, EntitySet.Description);
    Operation := Path.Put;
    Operation.Tags.Add(TagName);
    Operation.OperationId := 'Update' + EntitySet.Name + OperationSuffix;
    AddKeyParameters(Operation, KeyNames, KeyProps);
    Operation.Consumes.Add(JsonMediaType);
    Operation.BodyParameter(BuildSchema(Clazz.ClassInfo));
    Operation.Produces.Add(JsonMediaType);
    Operation.Responses.Add('200', TResponse.Create(SuccessfulResponse,
      BuildSchema(Clazz.ClassInfo)));

    // MergeEntity operation: PATCH operation on entity
    Operation := Path.Patch;
    Operation.Tags.Add(TagName);
    Operation.OperationId := 'Merge' + EntitySet.Name + OperationSuffix;
    AddKeyParameters(Operation, KeyNames, KeyProps);
    Operation.Consumes.Add(JsonMediaType);
    Operation.BodyParameter(BuildSchema(Clazz.ClassInfo));
    Operation.Produces.Add(JsonMediaType);
    Operation.Responses.Add('200', TResponse.Create(SuccessfulResponse,
      BuildSchema(Clazz.ClassInfo)));
  end;

  // DeleteEntity operation: PATCH operation on entity
  if FModule.HasEndpoint(TEntitySetPermission.Delete, EntitySet) then
  begin
    FDocument.AddTag(TagName, EntitySet.Description);
    Operation := Path.Delete;
    Operation.Tags.Add(TagName);
    Operation.OperationId := 'Delete' + EntitySet.Name + OperationSuffix;
    AddKeyParameters(Operation, KeyNames, KeyProps);
    Operation.Responses.Add('204', TResponse.Create(SuccessfulResponse, nil));
  end;
end;

constructor TOpenApiBuilder.Create(AModule: TXDataServerModule);
begin
  FRtti := TRttiContext.Create;
  FModule := AModule;
  FModel := AModule.XModel;
end;

end.
