freepascal.compiler/packages/fcl-web/examples/httpserver/threadedhttpserver.pas

program threadedhttpserver;

{$mode objfpc}{$H+}
{$define UseCThreads}

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  sysutils, Classes, fphttpserver, fpmimetypes, testhttpserver, syncobjs;

Type
  TServerThread = class(TThread)
  private
    FCSWriteln: TCriticalSection;
    FServ : TTestHTTPServer;
    procedure ServOnIdle(Sender: TObject);
    procedure WriteInfo(S: string);
  public
    procedure Execute; override;
    constructor Create(CreateSuspended: Boolean; const StackSize: SizeUInt = DefaultStackSize);
    destructor Destroy; override;
  end;

{ TServerThread }

constructor TServerThread.Create(CreateSuspended: Boolean; const StackSize: SizeUInt);
begin
  inherited;

  FCSWriteln := TCriticalSection.Create;

  FServ:=TTestHTTPServer.Create(Nil);
  FServ.BaseDir:=ExtractFilePath(ParamStr(0));
{$ifdef unix}
  FServ.MimeTypesFile:='/etc/mime.types';
{$endif}
  FServ.Threaded:=True;
  FServ.KeepAliveEnabled:=True;
  FServ.KeepAliveTimeout:=60*1000;
  FServ.Port:=8080;
  FServ.WriteInfo := @WriteInfo;
  FServ.AcceptIdleTimeout := 500;
  FServ.OnAcceptIdle := @ServOnIdle;
end;

destructor TServerThread.Destroy;
begin
  FCSWriteln.Free;
  FServ.Free;
  inherited Destroy;
end;

procedure TServerThread.Execute;
begin
  FServ.Active:=True;
end;

procedure TServerThread.ServOnIdle(Sender: TObject);
begin
  if Terminated then
    FServ.Active := False;
end;

procedure TServerThread.WriteInfo(S: string);
begin
  FCSWriteln.Enter;
  WriteLn(S);
  FCSWriteln.Leave;
end;

var
  T: TServerThread;
begin
  T := TServerThread.Create(True);
  T.FreeOnTerminate := False;
  T.Start;
  WriteLn('Press enter to close server.');
  ReadLn;
  T.Terminate;
  T.WaitFor;
  T.Free;
end.