mORMot Open Source

function TSQLRestClientURI.URI(const url, method: RawUTF8; Resp, Head, SendData: PRawUTF8): Int64Rec;
var
  Retry: Integer;
  aUserName, aPassword: string;
  StatusMsg: RawUTF8;
  Call: TSQLRestURIParams;
  aPasswordHashed: Boolean;

  procedure DoRetry;
  begin
    Call.Url := url;
    if fSessionAuthentication <> nil then
      fSessionAuthentication.ClientSessionSign(Self, Call);
    Call.Method := method;
    if SendData <> nil then
      Call.InBody := SendData^;

    {$ifndef LVCL}
    if Assigned(fOnIdle) then begin
      if fBackgroundThread = nil then
        fBackgroundThread := TSynBackgroundThreadEvent.Create(OnBackgroundProcess, OnIdle, FormatUTF8('% "%" background', [Self, Model.Root]));
      if not fBackgroundThread.RunAndWait(@Call) then
        Call.OutStatus := HTTP_UNAVAILABLE;
    end
    else
    {$endif}
    begin
      InternalURI(Call);
      if not(ioNoOpen in fInternalOpen) then
        if (Call.OutStatus = HTTP_NOTIMPLEMENTED) and (ioOpened in fInternalOpen) then begin
          InternalClose;     // force recreate connection
          Exclude(fInternalOpen, ioOpened);
          InternalURI(Call); // try request again
        end
        else
          Include(fInternalOpen, ioOpened);
    end;

    Result.Lo := Call.OutStatus;
    Result.Hi := Call.OutInternalState;
    if Head <> nil then
      Head^ := Call.OutHead;
    if Resp <> nil then
      Resp^ := Call.OutBody;
    fLastErrorCode := Call.OutStatus;
  end;

begin
  if Self = nil then begin
    Int64(Result) := HTTP_UNAVAILABLE;
    SetLastException(nil, HTTP_UNAVAILABLE);
    Exit;
  end;

  fLastErrorMessage := '';
  fLastErrorException := nil;
  if fServerTimeStampOffset = 0 then begin
    if not ServerTimeStampSynchronize then begin
      Int64(Result) := HTTP_UNAVAILABLE;
      Exit; // if TimeStamp is not available, server is down!
    end;
  end;

  Call.Init;
  if (Head <> nil) and (Head^ <> '') then
    Call.InHead := Head^;
  if fSessionHttpHeader <> '' then
    Call.InHead := Trim(Call.InHead + #13#10 + fSessionHttpHeader);

  try
    DoRetry;
    if (Call.OutStatus = HTTP_TIMEOUT) and RetryOnceOnTimeout then begin
      InternalLog('% % returned "408 Request Timeout" -> RETRY', [method, url], sllError);
      DoRetry;
    end
    else if (Call.OutStatus = HTTP_FORBIDDEN) and Assigned(OnAuthentificationFailed) then begin
      Retry := 1;
      while Retry <= MaximumAuthentificationRetry do begin
        // "403 Forbidden" in case of authentication failure -> try relog
        if OnAuthentificationFailed(Retry, aUserName, aPassword, aPasswordHashed)
        and SetUser(StringToUTF8(aUserName), StringToUTF8(aPassword), aPasswordHashed) then begin
          DoRetry;
          Break;
        end;
        Inc(Retry);
      end;
    end;

    if not StatusCodeIsSuccess(Call.OutStatus) then begin
      StatusCodeToErrorMsg(Call.OutStatus, StatusMsg);
      if Call.OutBody = '' then
        fLastErrorMessage := StatusMsg
      else
        fLastErrorMessage := Call.OutBody;
      InternalLog('% % returned % (%) with message  %', 
        [method, url, Call.OutStatus, StatusMsg, fLastErrorMessage], sllError);
      if Assigned(fOnFailed) then
        fOnFailed(Self, nil, @Call);
    end;

  except
    on E: Exception do begin
      Int64(Result) := HTTP_NOTIMPLEMENTED; // 501
      SetLastException(E, HTTP_NOTIMPLEMENTED, @Call);
      Exit;
    end;
  end;
end;

if not OnAuthentificationFailed(Retry+2,aUserName,aPassword,aPasswordHashed) or
  not SetUser(StringToUTF8(aUserName),StringToUTF8(aPassword),aPasswordHashed) then
  break;

program Server;

{$APPTYPE CONSOLE}

uses
  {$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
  mORMot, mORMotHttpServer, mORMotSQLite3,
  SynCommons,
  SynDB,
  SynDBSQLite3, SynSQLite3, SynSQLite3Static, mORMotDB,
  chinook;

var
  DBConnProps: TSQLDBSQLite3ConnectionProperties;
  Model: TSQLModel;
  DBServer: TSQLRestServerDB;
  HttpServer: TSQLHttpServer;
begin
  DBConnProps := TSQLDBSQLite3ConnectionProperties.Create('chinook.db', '', '', '');
  try
    Model := CreateModel;
    VirtualTableExternalRegisterAll(Model, DBConnProps);
    Model.Props[TSQLalbum_artist].NoCreateMissingTable := TRUE;
    Model.Props[TSQLartists].ExternalDB.MapField('ID', 'ArtistId');
    Model.Props[TSQLalbums].ExternalDB.MapField('ID', 'AlbumId');
    try
      DBServer := TSQLRestServerDB.Create(Model, 'chinook.db', TRUE);
      try
        DBServer.CreateMissingTables;
        HttpServer := TSQLHttpServer.Create('8080', [DBServer], '+', HTTP_DEFAULT_MODE);
        try
          HttpServer.AccessControlAllowOrigin := '*';
          Writeln(#10'Background HTTP server is running.'#10);
          Writeln('Press [Enter] to close the server.'#10);
          readln;
        finally
          HttpServer.Free;
        end;
      finally
        DBServer.Free;
      end;
    finally
      Model.Free;
    end;
  finally
    DBConnProps.Free;
  end;
end.

unit chinook;

interface

uses
  SynCommons, mORMot;

type
  TSQLartists = class(TSQLRecord)
  private
    fName: RawUTF8;
  published
    property Name: RawUTF8 read fName write fName;
  end;

  TSQLalbums = class(TSQLRecord)
  private
    fTitle: RawUTF8;
    fArtistId: TSQLartists;
  published
    property Title: RawUTF8 read fTitle write fTitle;
    property ArtistId: TSQLartists read fArtistId write fArtistId;
  end;

  // VIEW
  TSQLalbum_artist = class(TSQLRecord)
  private
    fTitle: RawUTF8;
    fName: RawUTF8;
  published
    property Title: RawUTF8 read fTitle write fTitle;
    property Name: RawUTF8 read fName write fName;
  end;

const
  ROOT_NAME = 'root';

function CreateModel: TSQLModel;
  
implementation

function CreateModel: TSQLModel;
begin
  Result := TSQLModel.Create([TSQLartists,
                              TSQLalbums,
                              TSQLalbum_artist],
                              ROOT_NAME);
end;

end.

procedure TfrmClient.btnTestClick(Sender: TObject);
var
  aAlbumArtist: TSQLalbum_artist;
begin
  // Test 1: OK
  aAlbumArtist := TSQLalbum_artist.Create(Database, 1);
  // aAlbumArtist := TSQLalbum_artist.Create;
  // Database.Retrieve(1, aAlbumArtist);
  try
    mmoResult.Lines.Add(UTF8ToString(ObjectToJSON(aAlbumArtist)));
  finally
    aAlbumArtist.Free;
  end;

  // Test 2: NOT OK
  aAlbumArtist := TSQLalbum_artist.CreateAndFillPrepare(Database, 'RowID < ?', [10]);
  // aAlbumArtist := TSQLalbum_artist.CreateAndFillPrepare(Database, 'ID < ?', [10]);
  try
    with mmoResult.Lines do begin
      BeginUpdate;
      while aAlbumArtist.FillOne do
        Add(UTF8ToString(ObjectToJSON(aAlbumArtist)));
      EndUpdate;
    end;
  finally
    aAlbumArtist.Free;
  end;
end;

CREATE VIEW "album_artist" AS 
SELECT
albums.AlbumId AS RowID,
albums.Title,
artists.Name
FROM
artists
INNER JOIN albums ON albums.ArtistId = artists.Artistid

TSQLalbum_artist = class(TSQLRecord)
private
  fTitle: RawUTF8;
  fName: RawUTF8;
published
  property Title: RawUTF8 read fTitle write fTitle;
  property Name: RawUTF8 read fName write fName;
end;

Model.Props[TSQLartists].ExternalDB.MapField('ID', 'ArtistId');
VirtualTableExternalRegisterAll(Model, DBConnProps);

VirtualTableExternalRegisterAll(Model, DBConnProps);
Model.Props[TSQLartists].ExternalDB.MapField('ID', 'ArtistId');

Model := TSQLModel.Create([TSQLRecordClass1, TSQLRecordClass2], ROOT_NAME);
Model.VirtualTableRegister(TSQLRecordClass2, TSQLVirtualTableBinary); // TSQLRecordClass2 models the view
Server := TSQLRestServerDB.Create(Model, 'mydb.sqlite', TRUE);
Server.CreateMissingTables;
...