add threadedhttpserver demo

packages/fcl-web/examples/httpserver/simplehttpserver.pas

@@ -7,98 +7,35 @@ uses
   {$IFDEF UNIX}{$IFDEF UseCThreads}
   cthreads,
   {$ENDIF}{$ENDIF}
-  sysutils, Classes, fphttpserver, fpmimetypes, wmecho;
+  sysutils, Classes, fphttpserver, fpmimetypes, testhttpserver;
 
 Type
 
   { TTestHTTPServer }
 
-  TTestHTTPServer = Class(TFPHTTPServer)
-  private
-    FBaseDir : String;
-    FCount : Integer;
-    FMimeLoaded : Boolean;
-    FMimeTypesFile: String;
-    procedure SetBaseDir(const AValue: String);
+  THTTPServer = Class(TTestHTTPServer)
   Protected
     Procedure DoIdle(Sender : TObject);
-    procedure CheckMimeLoaded;
-
-    Property MimeLoaded : Boolean Read FMimeLoaded;
-  public
-    procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
-                            Var AResponse : TFPHTTPConnectionResponse); override;
-    Property BaseDir : String Read FBaseDir Write SetBaseDir;
-    Property MimeTypesFile : String Read FMimeTypesFile Write FMimeTypesFile;
-
+    procedure DoWriteInfo(S: string);
   end;
 
 Var
-  Serv : TTestHTTPServer;
-{ TTestHTTPServer }
+  Serv : THTTPServer;
 
-procedure TTestHTTPServer.SetBaseDir(const AValue: String);
-begin
-  if FBaseDir=AValue then exit;
-  FBaseDir:=AValue;
-  If (FBaseDir<>'') then
-    FBaseDir:=IncludeTrailingPathDelimiter(FBaseDir);
-end;
+{ THTTPServer }
 
-procedure TTestHTTPServer.DoIdle(Sender: TObject);
+procedure THTTPServer.DoIdle(Sender: TObject);
 begin
   Writeln('Idle, waiting for connections');
 end;
 
-procedure TTestHTTPServer.CheckMimeLoaded;
+procedure THTTPServer.DoWriteInfo(S: string);
 begin
-  If (Not MimeLoaded) and (MimeTypesFile<>'') then
-    begin
-    MimeTypes.LoadFromFile(MimeTypesFile);
-    FMimeLoaded:=true;
-    end;
-end;
-
-procedure TTestHTTPServer.HandleRequest(var ARequest: TFPHTTPConnectionRequest;
-  var AResponse: TFPHTTPConnectionResponse);
-
-Var
-  F : TFileStream;
-  FN : String;
-
-begin
-  FN:=ARequest.Url;
-  If (length(FN)>0) and (FN[1]='/') then
-    Delete(FN,1,1);
-  DoDirSeparators(FN);
-  FN:=BaseDir+FN;
-  if FileExists(FN) then
-    begin
-    F:=TFileStream.Create(FN,fmOpenRead);
-    try
-      CheckMimeLoaded;
-      AResponse.ContentType:=MimeTypes.GetMimeType(ExtractFileExt(FN));
-      Writeln('Serving file: "',Fn,'". Reported Mime type: ',AResponse.ContentType);
-      AResponse.ContentLength:=F.Size;
-      AResponse.ContentStream:=F;
-      AResponse.SendContent;
-      AResponse.ContentStream:=Nil;
-    finally
-      F.Free;
-    end;
-    end
-  else
-    begin
-    AResponse.Code:=404;
-    AResponse.SendContent;
-    end;
-  Inc(FCount);
-  If FCount>=5 then
-    Active:=False;
+  Writeln(S);
 end;
 
 begin
-  Serv:=TTestHTTPServer.Create(Nil);
+  Serv:=THTTPServer.Create(Nil);
   try
     Serv.BaseDir:=ExtractFilePath(ParamStr(0));
 {$ifdef unix}
@@ -108,6 +45,7 @@ begin
     Serv.Port:=8080;
     Serv.AcceptIdleTimeout:=1000;
     Serv.OnAcceptIdle:=@Serv.DoIdle;
+    Serv.WriteInfo:=@Serv.DoWriteInfo;
     Serv.Active:=True;
   finally
     Serv.Free;

packages/fcl-web/examples/httpserver/testhttpserver.pas

@@ -0,0 +1,98 @@
+unit testhttpserver;
+
+{$mode objfpc}{$H+}
+{$define UseCThreads}
+
+interface
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  sysutils, Classes, fphttpserver, fpmimetypes;
+
+Type
+
+  TWriteInfoMethod = procedure(S: string) of object;
+
+  { TTestHTTPServer }
+
+  TTestHTTPServer = Class(TFPHTTPServer)
+  private
+    FBaseDir : String;
+    FCount : Integer;
+    FMimeLoaded : Boolean;
+    FMimeTypesFile: String;
+    FWriteInfo: TWriteInfoMethod;
+    procedure SetBaseDir(const AValue: String);
+  Protected
+    procedure CheckMimeLoaded;
+
+    Property MimeLoaded : Boolean Read FMimeLoaded;
+  public
+    procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
+                            Var AResponse : TFPHTTPConnectionResponse); override;
+    Property BaseDir : String Read FBaseDir Write SetBaseDir;
+    Property MimeTypesFile : String Read FMimeTypesFile Write FMimeTypesFile;
+    Property WriteInfo: TWriteInfoMethod Read FWriteInfo Write FWriteInfo;
+  end;
+
+implementation
+
+{ TTestHTTPServer }
+
+procedure TTestHTTPServer.SetBaseDir(const AValue: String);
+begin
+  if FBaseDir=AValue then exit;
+  FBaseDir:=AValue;
+  If (FBaseDir<>'') then
+    FBaseDir:=IncludeTrailingPathDelimiter(FBaseDir);
+end;
+
+procedure TTestHTTPServer.CheckMimeLoaded;
+begin
+  If (Not MimeLoaded) and (MimeTypesFile<>'') then
+    begin
+    MimeTypes.LoadFromFile(MimeTypesFile);
+    FMimeLoaded:=true;
+    end;
+end;
+
+procedure TTestHTTPServer.HandleRequest(var ARequest: TFPHTTPConnectionRequest;
+  var AResponse: TFPHTTPConnectionResponse);
+
+Var
+  F : TFileStream;
+  FN : String;
+
+begin
+  FN:=ARequest.Url;
+  If (length(FN)>0) and (FN[1]='/') then
+    Delete(FN,1,1);
+  DoDirSeparators(FN);
+  FN:=BaseDir+FN;
+  if FileExists(FN) then
+    begin
+    F:=TFileStream.Create(FN,fmOpenRead or fmShareDenyNone);
+    try
+      CheckMimeLoaded;
+      AResponse.ContentType:=MimeTypes.GetMimeType(ExtractFileExt(FN));
+      WriteInfo('Serving file: "'+Fn+'". Reported Mime type: '+AResponse.ContentType);
+      AResponse.ContentLength:=F.Size;
+      AResponse.ContentStream:=F;
+      AResponse.SendContent;
+      AResponse.ContentStream:=Nil;
+    finally
+      F.Free;
+    end;
+    end
+  else
+    begin
+    AResponse.Code:=404;
+    AResponse.SendContent;
+    end;
+  Inc(FCount);
+end;
+
+end.
+

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

@@ -0,0 +1,84 @@
+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.
+