xtool/contrib/mORMot/SQLite3/Samples/27 - CrossPlatform Clients/PeopleServer.pas

unit PeopleServer;

interface

{$define TESTRECORD}

uses
  SynCommons,
  mORMot,
  mORMotHttpServer,
  mORMotWrappers,
  SynMustache,
  SysUtils;

type
  {$ifdef TESTRECORD}
  TRecordEnum = (reOne, reTwo, reLast);

  TTestCustomJSONArraySimpleArray = packed record
    F: RawUTF8;
    G: array of RawUTF8;
    H: record
      H1: integer;
      H2: WideString;
      H3: record
        H3a: boolean;
        H3b: RawByteString;
      end;
    end;
    I: TDateTime;
    J: array of packed record
      J1: byte;
      J2: TGUID;
      J3: TRecordEnum;
    end;
  end;
  {$endif TESTRECORD}

  {
  TRecB=packed record
    a1:array of packed record
      v1,v2:integer;
    end;
    a2:array of integer;
    v1:integer;
  end;
  }

  TPeopleSexe = (sFemale, sMale);

  TPeopleSexeDynArray = array of TPeopleSexe;

  TSimpleRecord = packed record
    A,B: integer;
    C: RawUTF8;
  end;

  TSimpleRecordDynArray = array of TSimpleRecord;

  TSQLRecordPeople = class(TSQLRecord)
  protected
    fData: TSQLRawBlob;
    fFirstName: RawUTF8;
    fLastName: RawUTF8;
    fYearOfBirth: integer;
    fYearOfDeath: word;
    fAnother: TSQLRecordPeople;
    {$ifdef TESTRECORD}
    fSexe: TPeopleSexe;
    fSimple: TTestCustomJSONArraySimpleArray;
  public
    class procedure InternalRegisterCustomProperties(Props: TSQLRecordProperties); override;
    {$endif}
  published
    property FirstName: RawUTF8 read fFirstName write fFirstName;
    property LastName: RawUTF8 read fLastName write fLastName;
    property Data: TSQLRawBlob read fData write fData;
    property YearOfBirth: integer read fYearOfBirth write fYearOfBirth;
    property YearOfDeath: word read fYearOfDeath write fYearOfDeath;
    property Another: TSQLRecordPeople read fAnother write fAnother;
  {$ifdef TESTRECORD}
    property Sexe: TPeopleSexe read fSexe write fSexe;
  public
    property Simple: TTestCustomJSONArraySimpleArray read fSimple;
  {$endif}
  end;

  ICalculator = interface(IInvokable)
    ['{9A60C8ED-CEB2-4E09-87D4-4A16F496E5FE}']
    function Add(n1,n2: integer): integer;
    procedure ToText(Value: Currency; const Curr: RawUTF8;
      var Sexe: TPeopleSexe; var Name: RawUTF8);
    {$ifdef TESTRECORD}
    function RecordToText(var Rec: TTestCustomJSONArraySimpleArray): string;
    {$endif}
    function GetPeople(id: TID; out People: TSQLRecordPeople;
      out Sexes: TPeopleSexeDynArray; var arr: TSimpleRecordDynArray): boolean;
//      var rec: TRecB): boolean;
    //function Test(toto: integer): TServiceCustomAnswer;
  end;

  TCustomServer = class(TSQLRestServerFullMemory)
  published
    procedure DropTable(Ctxt: TSQLRestServerURIContext);
  end;

  TPeopleServerAuthentication = (psaNone,psaWeak,psaDefault);


procedure StartServer(auth: TPeopleServerAuthentication);

procedure StopServer;


implementation

{ TServiceCalculator }

type
  TServiceCalculator = class(TInterfacedObject, ICalculator)
  public
    function Add(n1,n2: integer): integer;
    procedure ToText(Value: Currency; const Curr: RawUTF8;
      var Sexe: TPeopleSexe; var Name: RawUTF8);
    {$ifdef TESTRECORD}
    function RecordToText(var Rec: TTestCustomJSONArraySimpleArray): string;
    {$endif}
    function GetPeople(id: TID; out People: TSQLRecordPeople;
      out Sexes: TPeopleSexeDynArray; var arr: TSimpleRecordDynArray): boolean;
//      var rec: TRecB): boolean;
    function Test(toto: integer): TServiceCustomAnswer;
  end;

function TServiceCalculator.Add(n1, n2: integer): integer;
begin
  result := n1+n2;
end;

procedure TServiceCalculator.ToText(Value: Currency; const Curr: RawUTF8;
  var Sexe: TPeopleSexe; var Name: RawUTF8);
const SEX_TEXT: array[TPeopleSexe] of RawUTF8 = ('Miss','Mister');
begin
  Name := FormatUTF8('% % for % %',[Curr,Value,SEX_TEXT[Sexe],Name]);
  Sexe := sFemale;
end;

function TServiceCalculator.GetPeople(id: TID;
  out People: TSQLRecordPeople; out Sexes: TPeopleSexeDynArray;
  var arr: TSimpleRecordDynArray{; var rec: TRecB}): boolean;
var n: integer;
begin
  result := ServiceContext.Request.Server.Retrieve(id,People);
  n := length(arr);
  SetLength(arr,n+1);
  arr[n].A := id;
  arr[n].C := People.FirstName;
end;


{$ifdef TESTRECORD}

function TServiceCalculator.RecordToText(var Rec: TTestCustomJSONArraySimpleArray): string;
var n: integer;
begin
  result := UTF8ToString(RecordSaveJSON(Rec,TypeInfo(TTestCustomJSONArraySimpleArray)));
  Rec.F := Rec.F+'!';
  n := length(Rec.G);
  SetLength(Rec.G,n+1);
  Rec.G[n] := UInt32ToUtf8(n+1);
  inc(Rec.H.H1);
  if n=0 then
    exit; // first return J[] with nothing
  n := length(Rec.J);
  SetLength(Rec.J,n+1);
  Rec.J[n].J1 := n;
  Rec.J[n].J2.D2 := n;
  Rec.J[n].J3 := TRecordEnum(n mod (ord(high(TRecordEnum))+1));
end;

{$endif}

{ TCustomServer }

procedure TCustomServer.DropTable(Ctxt: TSQLRestServerURIContext);
begin
  if (Ctxt.Method=mGET) and (Ctxt.TableIndex>=0) then begin
    TSQLRestStorageInMemory(fStaticData[Ctxt.TableIndex]).DropValues;
    Ctxt.Success;
  end;
end;


var Model: TSQLModel;
    DB: TCustomServer;
    Server: TSQLHttpServer;

procedure StartServer(auth: TPeopleServerAuthentication);
begin
  StopServer;
  //TSQLLog.Family.Level := LOG_VERBOSE;
  Model := TSQLModel.Create([TSQLAuthUser,TSQLAuthGroup,TSQLRecordPeople]);
  DB := TCustomServer.Create(Model);
  Server := TSQLHttpServer.Create('888',DB);
  Server.AccessControlAllowOrigin := '*';
  case auth of
  psaDefault:
    DB.AuthenticationRegister(TSQLRestServerAuthenticationDefault);
  psaWeak:
    DB.AuthenticationRegister(TSQLRestServerAuthenticationNone);
  end;
  if DB.TableRowCount(TSQLRecordPeople)=0 then
    // we expect at least one record
    if DB.AddSimple(TSQLRecordPeople,['First1','Last1',1801,1826,1{$ifdef TESTRECORD},0,''{$endif}])=0 then
      writeln('StartServer DB.Add(TSQLRecordPeople) Error');
    // in all cases, client will call DropTable method-based service
  AddToServerWrapperMethod(DB,['..\..\..\CrossPlatform\templates',
                                '..\..\..\..\CrossPlatform\templates']);
  {$ifndef FPC}
  DB.ServiceRegister(TServiceCalculator,[TypeInfo(ICalculator)],sicShared);
  {$endif}
end;

procedure StopServer;
begin
  FreeAndNil(Server);
  FreeAndNil(DB);
  FreeAndNil(Model);
end;

{$ifdef TESTRECORD}

{ TSQLRecordPeople }

const
  __TTestCustomJSONArraySimpleArray =
  'F RawUTF8 G array of RawUTF8 '+
  'H {H1 integer H2 WideString H3{H3a boolean H3b RawByteString}} I TDateTime '+
  'J [J1 byte J2 TGUID J3 TRecordEnum]';
  __TSimpleRecord = 'A,B:integer C: RawUTF8';
   __TRecB = 'a2:array of integer v1:integer';
  //  __TRecB = 'a1 [v1,v2:integer] a2:array of integer v1:integer';

class procedure TSQLRecordPeople.InternalRegisterCustomProperties(
  Props: TSQLRecordProperties);
begin
  Props.RegisterCustomPropertyFromRTTI(Self,TypeInfo(TTestCustomJSONArraySimpleArray),
    'Simple',@TSQLRecordPeople(nil).fSimple);
end;

function TServiceCalculator.Test(toto: integer): TServiceCustomAnswer;
begin
  result.Header := TEXT_CONTENT_TYPE_HEADER;
  result.Content := Int32ToUtf8(toto);
  result.Status := HTTP_SUCCESS;
end;

initialization
  TTextWriter.RegisterCustomJSONSerializerFromTextSimpleType(TypeInfo(TRecordEnum));
  TTextWriter.RegisterCustomJSONSerializerFromText(
    TypeInfo(TTestCustomJSONArraySimpleArray),__TTestCustomJSONArraySimpleArray);
  TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TSimpleRecord),__TSimpleRecord);
//  TTextWriter.RegisterCustomJSONSerializerFromText(TypeInfo(TRecB),__TRecB);


{$endif TESTRECORD}

end.