unit Sparkle.HttpSys.Server;

{$I Sparkle.Inc}

interface

{$IFDEF MSWINDOWS}

uses
  Generics.Collections, Classes, SysUtils, SyncObjs,
  Sparkle.HttpServer.Module,
  Sparkle.HttpServer.Dispatcher,
  Sparkle.HttpSys.Context,
  Sparkle.HttpSys.Session,
  Sparkle.Logger,
  Sparkle.Sys.ThreadPool,
  Sparkle.Uri;

type
  EHttpSysServerException = class(Exception)
  end;

  TCustomHttpSysServer = class
  strict private
    const MainThreadTimeout = 15000;
  strict private
    FSession: THttpSysSession;
    FLogger: TLogger;
    FStopRequested: boolean;
    FMainEvent: TEvent;
    FThreadPool: TThreadPool;
    FDispatcher: THttpDispatcher;
    FKeepHostInUrlPrefixes: Boolean;
    procedure InternalStart;
    function GetIsRunning: boolean;
    procedure WaitMainThread;
    procedure WorkItemCallBack(Sender: TObject);
  strict private
    function GetLogEngine: ILogEngine;
    procedure SetLogEngine(const Value: ILogEngine);
  protected
    procedure BeforeStart; virtual;
    procedure DoProcessRequest(Context: THttpSysContext); virtual;
    property Session: THttpSysSession read FSession;
    property Logger: TLogger read FLogger;
  public
    procedure AddModule(AModule: THttpServerModule); overload;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Start;
    procedure Stop;
    property IsRunning: boolean read GetIsRunning;
    property LogEngine: ILogEngine read GetLogEngine write SetLogEngine;
    property Dispatcher: THttpDispatcher read FDispatcher;
    property KeepHostInUrlPrefixes: Boolean read FKeepHostInUrlPrefixes write FKeepHostInUrlPrefixes;
  end;

  THttpSysServer = class(TCustomHttpSysServer)
  end;

{$ENDIF}

implementation

{$IFDEF MSWINDOWS}

uses
  Winapi.Windows,
  Sparkle.Win.Socket;

type
  TServerWorkItem = class
  private
    FServer: TCustomHttpSysServer;
    FContext: THttpSysContext;
  public
    constructor Create(AContext: THttpSysContext; AServer: TCustomHttpSysServer);
    destructor Destroy; override;
    property Context: THttpSysContext read FContext;
    property Server: TCustomHttpSysServer read FServer;
  end;

{ THttpServer }

procedure TCustomHttpSysServer.AddModule(AModule: THttpServerModule);
begin
  FDispatcher.AddModule(AModule);
end;

procedure TCustomHttpSysServer.BeforeStart;
var
  ModuleInfo: THttpServerModuleInfo;
  UrlPrefix: string;
begin
  InitSocketLibrary;
  Session.UrlPrefixes.Clear;
  for ModuleInfo in FDispatcher.ModulesInfo do
  begin
    if KeepHostInUrlPrefixes then
      UrlPrefix := Format('%s://%s:%d%s',
        [ModuleInfo.BaseUri.Scheme,
         ModuleInfo.BaseUri.Host,
         ModuleInfo.BaseUri.Port,
         ModuleInfo.BaseUri.OriginalPath])
    else
      UrlPrefix := Format('%s://+:%d%s',
        [ModuleInfo.BaseUri.Scheme,
         ModuleInfo.BaseUri.Port,
         ModuleInfo.BaseUri.OriginalPath]);
    Session.UrlPrefixes.Add(UrlPrefix);
  end;
end;

constructor TCustomHttpSysServer.Create;
begin
  FSession := THttpSysSession.Create;
  FMainEvent := TEvent.Create;
  FMainEvent.SetEvent;
  FThreadPool := TWinThreadPool.Create;
  FLogger := TLogger.Create;
  FDispatcher := THttpDispatcher.Create;
end;

destructor TCustomHttpSysServer.Destroy;
begin
  Stop;
  FSession.Free;
  FMainEvent.Free;
  FThreadPool.Free;
  FLogger.Free;
  // This must be called after all other destructors that do all the needed operation
  // to stop and cleanup the server. If we call FDispatcher.Free before, there might be
  // threads processing the requests, and access violation might occur. So if we reach this point
  // we are sure all requests have been processed (or cancelled) and server is stopped.
  FDispatcher.Free;
  inherited;
end;

procedure TCustomHttpSysServer.DoProcessRequest(Context: THttpSysContext);
begin
  FDispatcher.DispatchRequest(Context);
end;

function TCustomHttpSysServer.GetIsRunning: boolean;
begin
  Result := (FSession <> nil) and FSession.IsListening;
end;

function TCustomHttpSysServer.GetLogEngine: ILogEngine;
begin
  Result := Logger.LogEngine;
end;

procedure TCustomHttpSysServer.InternalStart;
var
  C: THttpSysContext;
  StartEvent: TEvent;
begin
  BeforeStart;
  FSession.Start;
  FThreadPool.Start;
  FStopRequested := false;
  StartEvent := TEvent.Create;
  try
    TThread.CreateAnonymousThread(
      procedure()
      begin
        if FStopRequested then Exit;
        FMainEvent.ResetEvent;
        StartEvent.SetEvent;
        try
          {$IFDEF DEBUGLOG} Logger.Debug('Starting request loop'); {$ENDIF}
          while not FStopRequested do
            try
              {$IFDEF DEBUGLOG} Logger.Debug('Retrieving request'); {$ENDIF}
              C := FSession.GetContext;
              {$IFDEF DEBUGLOG} Logger.Debug('Returned from request retriever.'); {$ENDIF}
              if (C <> nil) and not FStopRequested then
              begin
                {$IFDEF DEBUGLOG} Logger.Debug(Format('Queueing work item for context id %d', [C.ContextId])); {$ENDIF}
                if not FThreadPool.QueueUserWorkItem(WorkItemCallBack, TServerWorkItem.Create(C, Self)) then
                  raise EHttpSysServerException.CreateFmt('Thread Pool Error: %s', [SysErrorMessage(GetLastError)]);
                {$IFDEF DEBUGLOG} Logger.Debug(Format('Work item queued for context id %d', [C.ContextId])); {$ENDIF}
              end;
            except
              on e: Exception do
              begin
                Logger.Log(Format('Leaving main server loop by exception. %s: %s',
                  [e.ClassName, e.Message]));
                raise;
              end;
            end;
          {$IFDEF DEBUGLOG} Logger.Debug('Leaving server by stop request.'); {$ENDIF}
        finally
          FSession.Stop;
          FMainEvent.SetEvent;
        end;
      end
    ).Start;

    if StartEvent.WaitFor(MainThreadTimeout) <> wrSignaled then
      raise EHttpSysServerException.Create('Could not start server main thread');
  finally
    StartEvent.Free;
  end;
end;

procedure TCustomHttpSysServer.SetLogEngine(const Value: ILogEngine);
begin
  Logger.LogEngine := Value;
  FDispatcher.LogEngine := Value;
end;

procedure TCustomHttpSysServer.Start;
begin
  if IsRunning then Exit;
  InternalStart;
end;

procedure TCustomHttpSysServer.Stop;
begin
  if not IsRunning then Exit;
  FStopRequested := true;
  FThreadPool.Stop;
  FSession.Stop;
  WaitMainThread;
end;

procedure TCustomHttpSysServer.WaitMainThread;
begin
  FMainEvent.WaitFor(MainThreadTimeout);
end;

procedure TCustomHttpSysServer.WorkItemCallBack(Sender: TObject);
var
  Context: THttpSysContext;
begin
  {$IFDEF DEBUGLOG} Logger.Enter('Work item call back'); {$ENDIF}
  try
    if TServerWorkItem(Sender).Server.FStopRequested then Exit;
    Context := TServerWorkItem(Sender).Context;
    DoProcessRequest(Context);
  finally
    TServerWorkItem(Sender).Free;
  end;
  {$IFDEF DEBUGLOG} Logger.Leave('Work item call back'); {$ENDIF}
end;

{ TServerWorkItem }

constructor TServerWorkItem.Create(AContext: THttpSysContext; AServer: TCustomHttpSysServer);
begin
  FContext := AContext;
  FServer := AServer;
end;

destructor TServerWorkItem.Destroy;
begin
  FContext.Free;
  inherited;
end;

{$ENDIF}

end.
