* Initial implementation of HTTP Server component

git-svn-id: trunk@17465 -

.gitattributes

@@ -2370,6 +2370,8 @@ packages/fcl-web/examples/combined/wmlogin.pp svneol=native#text/plain
 packages/fcl-web/examples/combined/wmusers.lfm svneol=native#text/plain
 packages/fcl-web/examples/combined/wmusers.lrs svneol=native#text/plain
 packages/fcl-web/examples/combined/wmusers.pp svneol=native#text/plain
+packages/fcl-web/examples/httpserver/simplehttpserver.lpi svneol=native#text/plain
+packages/fcl-web/examples/httpserver/simplehttpserver.pas svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/demo1/README.txt svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/demo1/demo.lpi svneol=native#text/plain
 packages/fcl-web/examples/jsonrpc/demo1/demo.lpr svneol=native#text/plain
@@ -2474,6 +2476,7 @@ packages/fcl-web/src/base/fpdatasetform.pp svneol=native#text/plain
 packages/fcl-web/src/base/fpfcgi.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphtml.pp svneol=native#text/plain
 packages/fcl-web/src/base/fphttp.pp svneol=native#text/plain
+packages/fcl-web/src/base/fphttpserver.pp svneol=native#text/plain
 packages/fcl-web/src/base/fpweb.pp svneol=native#text/plain
 packages/fcl-web/src/base/httpdefs.pp svneol=native#text/plain
 packages/fcl-web/src/base/iniwebsession.pp svneol=native#text/plain

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

@@ -0,0 +1,71 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <SaveOnlyProjectUnits Value="True"/>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="Simple HTTP server demo"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="simplehttpserver.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="simplehttpserver"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="10"/>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+    </SearchPaths>
+    <Other>
+      <CompilerMessages>
+        <UseMsgFile Value="True"/>
+      </CompilerMessages>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

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

@@ -0,0 +1,106 @@
+program simplehttpserver;
+
+{$mode objfpc}{$H+}
+{$define UseCThreads}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  sysutils, Classes, fphttpserver, fpmimetypes;
+
+Type
+
+  { TTestHTTPServer }
+
+  TTestHTTPServer = Class(TFPHTTPServer)
+  private
+    FBaseDir : String;
+    FCount : Integer;
+    FMimeLoaded : Boolean;
+    FMimeTypesFile: String;
+    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;
+  end;
+
+Var
+  Serv : TTestHTTPServer;
+{ 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);
+    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;
+end;
+
+begin
+  Serv:=TTestHTTPServer.Create(Nil);
+  try
+    Serv.BaseDir:=ExtractFilePath(ParamStr(0));
+{$ifdef unix}
+    Serv.MimeTypesFile:='/etc/mime.types';
+{$endif}
+    Serv.Threaded:=False;
+    Serv.Port:=8080;
+    Serv.Active:=True;
+  finally
+    Serv.Free;
+  end;
+end.
+

packages/fcl-web/src/base/fphttpserver.pp

@@ -0,0 +1,587 @@
+{
+    $Id: header,v 1.1 2000/07/13 06:33:45 michael Exp $
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2011- by the Free Pascal development team
+    
+    Simple HTTP server component.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit fphttpserver;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, ssockets, httpdefs;
+
+Const
+  ReadBufLen = 4096;
+
+Type
+  TFPHTTPConnection = Class;
+  TFPHTTPConnectionThread = Class;
+  TFPCustomHttpServer = Class;
+
+  { TFPHTTPConnectionRequest }
+
+  TFPHTTPConnectionRequest = Class(TRequest)
+  private
+    FConnection: TFPHTTPConnection;
+  protected
+    Property Connection : TFPHTTPConnection Read FConnection;
+  end;
+
+  { TFPHTTPConnectionResponse }
+
+  TFPHTTPConnectionResponse = Class(TResponse)
+  private
+    FConnection: TFPHTTPConnection;
+  Protected
+    Procedure DoSendHeaders(Headers : TStrings); override;
+    Procedure DoSendContent; override;
+    Property Connection : TFPHTTPConnection Read FConnection;
+  end;
+
+
+  { TFPHTTPConnection }
+
+  TFPHTTPConnection = Class(TObject)
+  private
+    FServer: TFPCustomHTTPServer;
+    FSocket: TSocketStream;
+    FBuffer : Ansistring;
+    procedure InterPretHeader(ARequest: TFPHTTPConnectionRequest; const AHeader: String);
+    function ReadString: String;
+  Protected
+    procedure ReadRequestContent(ARequest: TFPHTTPConnectionRequest); virtual;
+    procedure UnknownHeader(ARequest: TFPHTTPConnectionRequest; const AHeader: String); virtual;
+    Function ReadRequestHeaders : TFPHTTPConnectionRequest;
+  Public
+    Constructor Create(AServer : TFPCustomHTTPServer; ASocket : TSocketStream);
+    Destructor Destroy; override;
+    Procedure HandleRequest; virtual;
+    Property Socket : TSocketStream Read FSocket;
+    Property Server : TFPCustomHTTPServer Read FServer;
+  end;
+
+  { TFPHTTPConnectionThread }
+
+  TFPHTTPConnectionThread = Class(TThread)
+  private
+    FConnection: TFPHTTPConnection;
+  Public
+    Constructor CreateConnection(AConnection : TFPHTTPConnection); virtual;
+    Procedure Execute; override;
+    Property Connection : TFPHTTPConnection Read FConnection;
+  end;
+
+  { TFPHttpServer }
+  THTTPServerRequestHandler = Procedure (Sender: TObject;
+      Var ARequest: TFPHTTPConnectionRequest;
+      Var AResponse : TFPHTTPConnectionResponse) of object;
+
+  { TFPCustomHttpServer }
+
+  TFPCustomHttpServer = Class(TComponent)
+  Private
+    FOnAllowConnect: TConnectQuery;
+    FOnRequest: THTTPServerRequestHandler;
+    FPort: Word;
+    FQueueSize: Word;
+    FServer : TInetServer;
+    FLoadActivate : Boolean;
+    FThreaded: Boolean;
+    function GetActive: Boolean;
+    procedure SetActive(const AValue: Boolean);
+    procedure SetOnAllowConnect(const AValue: TConnectQuery);
+    procedure SetPort(const AValue: Word);
+    procedure SetQueueSize(const AValue: Word);
+    procedure SetThreaded(const AValue: Boolean);
+  Protected
+    // Create a connection handling object.
+    function CreateConnection(Data : TSocketStream) : TFPHTTPConnection; virtual;
+    // Create a connection handling thread.
+    Function CreateConnectionThread(Conn : TFPHTTPConnection) : TFPHTTPConnectionThread; virtual;
+    // Check if server is inactive
+    Procedure CheckInactive;
+    // Called by TInetServer when a new connection is accepted.
+    Procedure DoConnect(Sender : TObject; Data : TSocketStream); virtual;
+    // Create and configure TInetServer
+    Procedure CreateServerSocket; virtual;
+    // Stop and free TInetServer
+    Procedure FreeServerSocket; virtual;
+    // Handle request. This calls OnRequest. It can be overridden by descendants to provide standard handling.
+    procedure HandleRequest(Var ARequest: TFPHTTPConnectionRequest;
+                            Var AResponse : TFPHTTPConnectionResponse); virtual;
+  public
+    Constructor Create(AOwner : TComponent); override;
+    Destructor Destroy; override;
+  protected
+    // Set to true to start listening.
+    Property Active : Boolean Read GetActive Write SetActive Default false;
+    // Port to listen on.
+    Property Port : Word Read FPort Write SetPort Default 80;
+    // Max connections on queue (for Listen call)
+    Property QueueSize : Word Read FQueueSize Write SetQueueSize Default 5;
+    // Called when deciding whether to accept a connection.
+    Property OnAllowConnect : TConnectQuery Read FOnAllowConnect Write SetOnAllowConnect;
+    // Use a thread to handle a connection ?
+    property Threaded : Boolean read FThreaded Write SetThreaded;
+    // Called to handle the request. If Threaded=True, it is called in a the connection thread.
+    Property OnRequest : THTTPServerRequestHandler Read FOnRequest Write FOnRequest;
+  end;
+
+  TFPHttpServer = Class(TFPCustomHttpServer)
+  Published
+    Property Active;
+    Property Port;
+    Property QueueSize;
+    Property OnAllowConnect;
+    property Threaded;
+    Property OnRequest;
+  end;
+
+  EHTTPServer = Class(Exception);
+
+implementation
+
+resourcestring
+  SErrSocketActive    =  'Operation not allowed while server is active';
+  SErrReadingSocket   = 'Error reading data from the socket';
+  SErrMissingProtocol = 'Missing HTTP protocol version in request';
+
+{ TFPHTTPConnectionRequest }
+Function GetStatusCode (ACode: Integer) : String;
+
+begin
+  Case ACode of
+    100 :  Result:='Continue';
+    101 :  Result:='Switching Protocols';
+    200 :  Result:='OK';
+    201 :  Result:='Created';
+    202 :  Result:='Accepted';
+    203 :  Result:='Non-Authoritative Information';
+    204 :  Result:='No Content';
+    205 :  Result:='Reset Content';
+    206 :  Result:='Partial Content';
+    300 :  Result:='Multiple Choices';
+    301 :  Result:='Moved Permanently';
+    302 :  Result:='Found';
+    303 :  Result:='See Other';
+    304 :  Result:='Not Modified';
+    305 :  Result:='Use Proxy';
+    307 :  Result:='Temporary Redirect';
+    400 :  Result:='Bad Request';
+    401 :  Result:='Unauthorized';
+    402 :  Result:='Payment Required';
+    403 :  Result:='Forbidden';
+    404 :  Result:='Not Found';
+    405 :  Result:='Method Not Allowed';
+    406 :  Result:='Not Acceptable';
+    407 :  Result:='Proxy Authentication Required';
+    408 :  Result:='Request Time-out';
+    409 :  Result:='Conflict';
+    410 :  Result:='Gone';
+    411 :  Result:='Length Required';
+    412 :  Result:='Precondition Failed';
+    413 :  Result:='Request Entity Too Large';
+    414 :  Result:='Request-URI Too Large';
+    415 :  Result:='Unsupported Media Type';
+    416 :  Result:='Requested range not satisfiable';
+    417 :  Result:='Expectation Failed';
+    500 :  Result:='Internal Server Error';
+    501 :  Result:='Not Implemented';
+    502 :  Result:='Bad Gateway';
+    503 :  Result:='Service Unavailable';
+    504 :  Result:='Gateway Time-out';
+    505 :  Result:='HTTP Version not supported';
+  else
+    Result:='Unknown status';
+  end;
+end;
+
+procedure TFPHTTPConnectionResponse.DoSendHeaders(Headers: TStrings);
+
+Var
+  S : String;
+  I : Integer;
+begin
+  S:=Format('HTTP/1.1 %3d %s'#13#10,[Code,GetStatusCode(Code)]);
+  For I:=0 to Headers.Count-1 do
+    S:=S+Headers[i]+#13#10;
+  // Last line in headers is empty.
+  Connection.Socket.WriteBuffer(S[1],Length(S));
+end;
+
+procedure TFPHTTPConnectionResponse.DoSendContent;
+begin
+  If Assigned(ContentStream) then
+    Connection.Socket.CopyFrom(ContentStream,0)
+  else
+    Contents.SaveToStream(Connection.Socket);
+end;
+
+{ TFPHTTPConnection }
+
+function TFPHTTPConnection.ReadString : String;
+
+  Procedure FillBuffer;
+
+  Var
+    R : Integer;
+
+  begin
+    SetLength(FBuffer,ReadBufLen);
+    r:=FSocket.Read(FBuffer[1],ReadBufLen);
+    If r<0 then
+      Raise EHTTPServer.Create(SErrReadingSocket);
+    if (r<ReadBuflen) then
+      SetLength(FBuffer,r);
+  end;
+
+Var
+  CheckLF,Done : Boolean;
+  P,L : integer;
+
+begin
+  Result:='';
+  Done:=False;
+  CheckLF:=False;
+  Repeat
+    if Length(FBuffer)=0 then
+      FillBuffer;
+    if Length(FBuffer)=0 then
+      Done:=True
+    else if CheckLF then
+      begin
+      If (FBuffer[1]<>#10) then
+        Result:=Result+#13
+      else
+        begin
+        Delete(FBuffer,1,1);
+        Done:=True;
+        end;
+      end;
+    if not Done then
+      begin
+      P:=Pos(#13#10,FBuffer);
+      If P=0 then
+        begin
+        L:=Length(FBuffer);
+        CheckLF:=FBuffer[L]=#13;
+        if CheckLF then
+          Result:=Result+Copy(FBuffer,1,L-1)
+        else
+          Result:=Result+FBuffer;
+        FBuffer:='';
+        end
+      else
+        begin
+        Result:=Result+Copy(FBuffer,1,P-1);
+        Delete(FBuffer,1,P+1);
+        Done:=True;
+        end;
+      end;
+  until Done;
+end;
+
+procedure TFPHTTPConnection.UnknownHeader(ARequest: TFPHTTPConnectionRequest;
+  const AHeader: String);
+begin
+  // Do nothing
+end;
+
+Procedure TFPHTTPConnection.InterPretHeader(ARequest : TFPHTTPConnectionRequest; Const AHeader : String);
+
+Var
+  P : Integer;
+  N,V : String;
+
+begin
+  V:=AHeader;
+  P:=Pos(':',V);
+  if (P=0) then
+    begin
+    UnknownHeader(ARequest,Aheader);
+    Exit;
+    end;
+  N:=Copy(V,1,P-1);
+  Delete(V,1,P+1);
+  V:=Trim(V);
+  ARequest.SetFieldByName(N,V);
+end;
+
+procedure ParseStartLine(Request : TFPHTTPConnectionRequest; AStartLine : String);
+
+  Function GetNextWord(Var S : String) : string;
+
+  Var
+    P : Integer;
+
+  begin
+    P:=Pos(' ',S);
+    If (P=0) then
+      P:=Length(S)+1;
+    Result:=Copy(S,1,P-1);
+    Delete(S,1,P);
+  end;
+
+Var
+  S : String;
+
+begin
+  Request.Method:=GetNextWord(AStartLine);
+  Request.URL:=GetNextWord(AStartLine);
+  S:=GetNextWord(AStartLine);
+  If (Pos('HTTP/',S)<>1) then
+    Raise Exception.Create(SErrMissingProtocol);
+  Delete(S,1,5);
+  Request.ProtocolVersion:=trim(S);
+end;
+
+Procedure TFPHTTPConnection.ReadRequestContent(ARequest : TFPHTTPConnectionRequest);
+
+Var
+  P,L,R : integer;
+  S : String;
+
+begin
+  L:=ARequest.ContentLength;
+  If (L>0) then
+    begin
+    SetLength(S,L);
+    P:=Length(FBuffer);
+    if (P>0) then
+      Move(FBuffer[1],S,P);
+    P:=P+1;
+    Repeat
+      R:=FSocket.Read(S[p],L);
+      If R<0 then
+        Raise EHTTPServer.Create(SErrReadingSocket);
+      if (R>0) then
+        begin
+        P:=P+R;
+        L:=L-R;
+        end;
+    until (L=0) or (R=0);
+    end;
+  ARequest.Content:=S;
+end;
+
+function TFPHTTPConnection.ReadRequestHeaders: TFPHTTPConnectionRequest;
+
+Var
+  StartLine,S : String;
+begin
+  Result:=TFPHTTPConnectionRequest.Create;
+  Result.FConnection:=Self;
+  StartLine:=ReadString;
+  ParseStartLine(Result,StartLine);
+  Repeat
+    S:=ReadString;
+    if (S<>'') then
+      InterPretHeader(Result,S);
+  Until (S='');
+end;
+
+constructor TFPHTTPConnection.Create(AServer: TFPCustomHttpServer; ASocket: TSocketStream
+  );
+begin
+  FSocket:=ASocket;
+  FServer:=AServer;
+end;
+
+destructor TFPHTTPConnection.Destroy;
+begin
+  FreeAndNil(FSocket);
+  Inherited;
+end;
+
+procedure TFPHTTPConnection.HandleRequest;
+
+Var
+  Req : TFPHTTPConnectionRequest;
+  Resp : TFPHTTPConnectionResponse;
+
+begin
+  // Read headers.
+  Req:=ReadRequestHeaders;
+  try
+    // Read content, if any
+    If Req.ContentLength>0 then
+      ReadRequestContent(Req);
+    // Create Response
+    Resp:= TFPHTTPConnectionResponse.Create(Req);
+    try
+      Resp.FConnection:=Self;
+      // And dispatch
+      if Server.Active then
+        Server.HandleRequest(Req,Resp);
+      if Assigned(Resp) and (not Resp.ContentSent) then
+        Resp.SendContent;
+    finally
+      FreeAndNil(Resp);
+    end;
+  Finally
+    FreeAndNil(Req);
+  end;
+end;
+
+{ TFPHTTPConnectionThread }
+
+constructor TFPHTTPConnectionThread.CreateConnection(AConnection: TFPHTTPConnection
+  );
+begin
+  FConnection:=AConnection;
+  FreeOnTerminate:=True;
+  Inherited Create(False);
+end;
+
+procedure TFPHTTPConnectionThread.Execute;
+begin
+  try
+    try
+      FConnection.HandleRequest;
+    finally
+      FreeAndNil(FConnection);
+    end;
+  except
+    // Silently ignore errors.
+  end;
+end;
+
+{ TFPCustomHttpServer }
+
+function TFPCustomHttpServer.GetActive: Boolean;
+begin
+  if (csDesigning in ComponentState) then
+    Result:=FLoadActivate
+  else
+    Result:=Assigned(FServer);
+end;
+
+procedure TFPCustomHttpServer.SetActive(const AValue: Boolean);
+begin
+  If AValue=GetActive then exit;
+  FLoadActivate:=AValue;
+  if not (csDesigning in Componentstate) then
+    if AValue then
+      CreateServerSocket
+    else
+      FreeServerSocket;
+end;
+
+procedure TFPCustomHttpServer.SetOnAllowConnect(const AValue: TConnectQuery);
+begin
+  if FOnAllowConnect=AValue then exit;
+  CheckInactive;
+  FOnAllowConnect:=AValue;
+end;
+
+procedure TFPCustomHttpServer.SetPort(const AValue: Word);
+begin
+  if FPort=AValue then exit;
+  CheckInactive;
+  FPort:=AValue;
+end;
+
+procedure TFPCustomHttpServer.SetQueueSize(const AValue: Word);
+begin
+  if FQueueSize=AValue then exit;
+  CheckInactive;
+  FQueueSize:=AValue;
+end;
+
+procedure TFPCustomHttpServer.SetThreaded(const AValue: Boolean);
+begin
+  if FThreaded=AValue then exit;
+  CheckInactive;
+  FThreaded:=AValue;
+end;
+
+function TFPCustomHttpServer.CreateConnection(Data: TSocketStream): TFPHTTPConnection;
+begin
+  Result:=TFPHTTPConnection.Create(Self,Data);
+end;
+
+function TFPCustomHttpServer.CreateConnectionThread(Conn: TFPHTTPConnection
+  ): TFPHTTPConnectionThread;
+begin
+   Result:=TFPHTTPConnectionThread.CreateConnection(Conn);
+end;
+
+procedure TFPCustomHttpServer.CheckInactive;
+begin
+  If GetActive then
+    Raise EHTTPServer.Create(SErrSocketActive);
+end;
+
+procedure TFPCustomHttpServer.DoConnect(Sender: TObject; Data: TSocketStream);
+
+Var
+  Con : TFPHTTPConnection;
+
+begin
+  Con:=CreateConnection(Data);
+  try
+    Con.FServer:=Self;
+    if Threaded then
+      CreateConnectionThread(Con)
+    else
+      begin
+      Con.HandleRequest;
+      end;
+  finally
+    if not Threaded then
+      Con.Free;
+  end;
+end;
+
+procedure TFPCustomHttpServer.CreateServerSocket;
+begin
+  FServer:=TInetServer.Create(FPort);
+  FServer.MaxConnections:=-1;
+  FServer.OnConnectQuery:=OnAllowConnect;
+  FServer.OnConnect:=@DOConnect;
+  FServer.QueueSize:=Self.QueueSize;
+  FServer.Bind;
+  FServer.Listen;
+  FServer.StartAccepting;
+end;
+
+procedure TFPCustomHttpServer.FreeServerSocket;
+begin
+  FServer.StopAccepting;
+  FreeAndNil(FServer);
+end;
+
+procedure TFPCustomHttpServer.HandleRequest(var ARequest: TFPHTTPConnectionRequest;
+  var AResponse: TFPHTTPConnectionResponse);
+begin
+  If Assigned(FOnRequest) then
+    FonRequest(Self,ARequest,AResponse);
+end;
+
+constructor TFPCustomHttpServer.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FPort:=80;
+  FQueueSize:=5;
+end;
+
+destructor TFPCustomHttpServer.Destroy;
+begin
+  Active:=False;
+  inherited Destroy;
+end;
+
+end.
+

packages/fcl-web/src/base/fpweb.pp

@@ -127,7 +127,7 @@ Type
     Property AfterResponse : TResponseEvent Read FAfterResponse Write FAfterResponse;
     Property OnGetAction : TGetActionEvent Read GetOnGetAction Write SetOnGetAction;
     Property DefActionWhenUnknown : Boolean read GetDefActionWhenUnknown write SetDefActionWhenUnknown default true;
-    Property Template : TFPTemplate Read FTemplate Write SetTemplate;
+    Property ModuleTemplate : TFPTemplate Read FTemplate Write SetTemplate;
     Property OnGetParam : TGetParamEvent Read FOnGetParam Write FOnGetParam;
     Property OnTemplateContent : TGetParamEvent Read FOnGetParam Write FOnGetParam;
     Property Request: TRequest Read FRequest;

packages/fcl-web/src/base/httpdefs.pp

@@ -175,6 +175,7 @@ type
     FHTTPXRequestedWith: String;
     FFields : THttpFields;
     FQueryFields: TStrings;
+    FURL : String;
     function GetSetField(AIndex: Integer): String;
     function GetSetFieldName(AIndex: Integer): String;
     procedure SetCookieFields(const AValue: TStrings);
@@ -624,6 +625,7 @@ begin
   else
     case Index of
       0  : Result:=FHTTPVersion;
+      32 : Result:=FURL;
       36 : Result:=FHTTPXRequestedWith;
     else
       Result := '';
@@ -654,6 +656,7 @@ begin
       28 : ; // Property RemoteHost : String Index 28 read  GetFieldValue Write SetFieldValue;
       29 : ; // Property ScriptName : String Index 29 read  GetFieldValue Write SetFieldValue;
       30 : ; // Property ServerPort : Word Read GetServerPort; // Index 30
+      32 : FURL:=Value;
       36 : FHTTPXRequestedWith:=Value;
     end;
 end;