Chip 2002 September/Chip_2002-09_cd1.bin/zkuste/vbasic/Data/Utils/XZipComp.exe/XceedWinsock.Cab/F112694_unHttpServer.pas

Pascal/Delphi Source File | 2000-05-16 | 24.5 KB | 644 lines

unit unHttpServer;

{
  Xceed Winsock Library Sample: HTTP Server
  Copyright (c) 2000 Xceed Software Inc.

  This is a very basic implementation of an HTTP server. It
  only handles the "GET" HTTP command. When a "GET" command
  is received from a client, the server will send the requested
  file to the client. The path of the "GET" request is relative
  to the server EXE file.

  This sample demonstrates how to use a listening socket to
  wait and accept incoming client connections, and how to use
  string and file transfer methods.

  It also shows how to receive dispatch events from the event objects, using
  the .PAS files you can find under the "Include" subfolder of the
  Xceed Winsock Library's installation folder.

  This file is part of the Xceed Winsock Library Samples.
  The source code in this file is only intended as a supplement
  to Xceed Winsock Library's documentation, and is provided "as is",
  without warranty of any kind, either expressed or implied.
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, XCEEDWINSOCKlib_TLB,
  { These files are distributed with the Xceed Winsock Library, and are used
    to receive dispatch events triggered by the event objects. The other way
    to receive events involves implementing the IaXWXxxEvents interfaces, but
    this results in slightly different parameter types that can confuse
    someone not used to playing with the many interfaces of a COM object. }
  xwlIncomingConnectionEvents,
  xwlConnectionEvents,
  xwlStringTransferEvents,
  xwlFileTransferEvents;

type
  { This class will hold each HTTP request, since these reuqests may not be
    received in a single paquet. }

  PHttpRequest = ^THttpRequest;
  THttpRequest = record
    m_sRequest : WideString;
    m_xConnection : ConnectionOrientedSocket;
  end;

  { This is our main form }

  TfrmMain = class( TForm,
                    { The following interfaces are declared in the above
                      mentionned files. We need to implement these interfaces
                      to receive events. }
                    IIncomingConnectionEvents,
                    IConnectionEvents,
                    IStringTransferEvents,
                    IFileTransferEvents )
    { Controls on the form }
    Label1           : TLabel;
    lstClients       : TListBox;
    Label2           : TLabel;
    lstLog           : TListBox;
    Label3           : TLabel;
    txtPort          : TEdit;
    btStartListening : TButton;
    btStopListening  : TButton;
    lblStatus        : TLabel;
    lblConnections   : TLabel;

    { Standard events }
    procedure btStartListeningClick(Sender: TObject);
    procedure btStopListeningClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);

    { IIncomingConnectionEvents }
    procedure OnConnection( const xListeningSocket : IDispatch;
                            const xRemoteAddress : IDispatch;
                            vaCallerData : OleVariant;
                            lExpectedCalleeDataSize : Integer;
                            var vaCalleeData : OleVariant;
                            var xQualityOfService : IdXWQualityOfServiceInfo;
                            var lUserParam : Integer;
                            var bReject : WordBool );
    procedure OnConnectionProcessed( const xListeningSocket : IDispatch;
                                     const xIncomingSocket : IDispatch;
                                     lUserParam : Integer );
    procedure OnListeningError( const xListeningSocket : IDispatch;
                                lUserParam: Integer;
                                lResultCode: Integer );

    { IConnectionEvents }
    procedure OnDisconnected( const xSocket : IDispatch;
                              vaCallerData : OleVariant;
                              var vaCalleeData : OleVariant );

    { IStringTransferEvents }
    procedure OnStringSent( const xSocket : IDispatch;
                            lUserParam : Integer;
                            lResultCode : Integer );
    procedure OnStringReceived( const xSocket : IDispatch;
                                const sString : WideString;
                                lUserParam : Integer;
                                lResultCode: Integer );
    procedure OnStringAvailable( const xSocket : IDispatch;
                                 lCharsReceived : Integer;
                                 lCharsAvailable : Integer );
    procedure OnOutOfBandStringReceived( const xSocket: IDispatch;
                                         const sString: WideString;
                                         lResultCode: Integer );

    { IFileTransferEvents }
    procedure OnFileSent( const xSocket : IDispatch;
                          const sFilename : WideString;
                          lStartOffset : Integer;
                          lBytesSent : Integer;
                          lBytesTotal : Integer;
                          lUserParam : Integer;
                          bTransferCompleted : WordBool;
                          lResultCode: Integer );
    procedure OnFileReceived( const xSocket : IDispatch;
                              const sFilename : WideString;
                              lStartOffset : Integer;
                              lBytesReceived : Integer;
                              lBytesTotal : Integer;
                              lUserParam : Integer;
                              bTransferCompleted : WordBool;
                              lResultCode : Integer );
    procedure FormDestroy(Sender: TObject);
  private
    { This member will keep a list of THttpRequest objects, holding requests
      from each connection. We must buffer requests like this since we are not
      guaranteed to receive the HTTP request in one shot. }

    m_lstRequests : TList;

    { These objects are implemented in the above included files to help you
      receive events throught the dispatch interface. }

    m_xIncomingConnectionEvents : TIncomingConnectionEvents;
    m_xConnectionEvents         : TConnectionEvents;
    m_xStringTransferEvents     : TStringTransferEvents;
    m_xFileTransferEvents       : TFileTransferEvents;

    { And their associated cookie! }

    m_lConnectionCookie     : LongInt;
    m_lStringTransferCookie : LongInt;
    m_lFileTransferCookie   : LongInt;

    { Socket used to accept incoming connections. It is held in a form member
      variable because it needs to stay "alive" as long as we want to be
      accepting incoming connections.}

    m_xListeningSocket : ListeningSocket;

    { Number of connected clients }

    m_nClientsCount : Integer;
  public
  end;

  { Some global functions for use with THttpRequest items }

  procedure AppendRequestString( pItem : PHttpRequest;
                                 sRequestString : WideString );
  function IsRequestComplete( pItem : PHttpRequest ) : Boolean;
  function GetRelativeFilename( pItem : PHttpRequest ) : WideString;
  function GetAbsoluteFilename( pItem : PHttpRequest ) : WideString;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

{------------------------------------------------------------------------------}
{              Global procedures for use with THttpRequest items               }
{------------------------------------------------------------------------------}

{ AppendRequestString: Add a string to the complete HTTP request currently
                       buffered. }

procedure AppendRequestString( pItem : PHttpRequest; sRequestString : WideString );
begin
  pItem^.m_sRequest := pItem^.m_sRequest + sRequestString;
end;

{------------------------------------------------------------------------------}
{ IsRequestCompleted: Tells if all the request is received from the client, by
                      checking for a double linefeed at the end. }

function IsRequestComplete( pItem : PHttpRequest ) : Boolean;
begin
  IsRequestComplete := ( Copy( pItem^.m_sRequest, Length( pItem^.m_sRequest ) - 3, 4)
                       = (#13#10 + #13#10) );
end;

{------------------------------------------------------------------------------}
{ GetRelativeFilename: Get the filename to asked by the client relative to the
                       root of the web site. }

function GetRelativeFilename( pItem : PHttpRequest ) : WideString;
var
  nGetEnd       : Integer;
  sRelativeName : WideString;
  nSlashPos     : Integer;
  sTemp         : WideString;
begin
  GetRelativeFilename := '';

  if IsRequestComplete( pItem ) then
  begin
    if Copy( pItem^.m_sRequest, 1, 4 ) = 'GET ' then
    begin
      sTemp := Copy( pItem^.m_sRequest, 5, Length( pItem^.m_sRequest ) - 4 );
      nGetEnd := Pos( ' ', sTemp );
      sRelativeName := Copy( sTemp, 1, nGetEnd - 1 );

      if sRelativeName = '/' then
        sRelativeName := '/index.html';

      repeat
        nSlashPos := Pos( '/', sRelativeName );
        if nSlashPos > 0 then
          sRelativeName[nSlashPos] := '\';
      until nSlashPos = 0;

      GetRelativeFilename := sRelativeName;
    end;
  end;
end;

{------------------------------------------------------------------------------}
{ GetAbsoluteFilename: Retrieve the relative filename and prepend our local
                       test web site path. }

function GetAbsoluteFileName( pItem : PHttpRequest ) : WideString;
var
  sRelativeName : WideString;
begin
  sRelativeName := GetRelativeFilename( pItem );

  if Length( sRelativeName ) > 0 then
    sRelativeName := ExtractFilePath( Application.ExeName ) + 'SampleSite' + sRelativeName;

  GetAbsoluteFilename := sRelativeName;
end;

{------------------------------------------------------------------------------}
{                      Implementation for class TfrmMain                       }
{------------------------------------------------------------------------------}

{ btStartListeningClick: We create the listening socket using the proper
                         protocol and local address, and enter the "listening"
                         state, in which the socket will be ready to accept
                         incoming client connections. }

procedure TfrmMain.btStartListeningClick(Sender: TObject);
var
  xProtocols     : Protocols;
  xProtocolTCP   : Protocol;
  xSocketFactory : SocketFactory;
  xListenAddress : InetAddress;
  xAddress       : Address;
begin
  btStartListening.Enabled := False;
  txtPort.Enabled := False;

  lstLog.Items.Add('Creating listening socket...');

  { The SocketFactory requires a Protocol to initialize the new socket with.
    We obtain the required Protocol by using the Protocols collection,
    and asking for a specific protocol. We could also have used For-Each to
    iterate through the Protocols collection and find our protocol. }

  xProtocols := CoProtocols.Create;
  xProtocolTCP := xProtocols.GetProtocol(wafInet, wstStream, wptIP_TCP);

  { Create the listening socket, using a SocketFactory object. }

  xSocketFactory := CoSocketFactory.Create;

  m_xListeningSocket := xSocketFactory.CreateListeningSocket(xProtocolTCP, 0);

  { Provide our event object instances to the listening socket. Those event
    objects will be used by all connected client sockets. The cookies are kept
    to do proper cleanup (Unadvise) when the listening socket will be freed. }

  m_lConnectionCookie := m_xListeningSocket.ConnectionAdvise(
                                            m_xConnectionEvents.m_xEventObject,
                                            wcaAdviseDisconnected);

  m_lStringTransferCookie := m_xListeningSocket.StringTransferAdvise(
                                        m_xStringTransferEvents.m_xEventObject,
                                        wsaAdviseReceivedAlways,
                                        wnfAnsiStrings);

  m_lFileTransferCookie := m_xListeningSocket.FileTransferAdvise(
                                          m_xFileTransferEvents.m_xEventObject,
                                          wfaAdviseFileSentCompleted);

  { Create the InetAddress object for the address on which the listening socket
    will wait for incoming connections. We only need to set the port on which
    we want to listen. }

  xListenAddress := CoInetAddress.Create;
  xListenAddress.Port := StrToInt(txtPort.text);

  { Enter the "listening" state. We provide the address on which we want to
    listen, and the event object that will be used to trigger incoming
    connection events. }

  lstLog.Items.Add('Starting to listen...');

  m_xListeningSocket.StartListening(xListenAddress,
                                    m_xIncomingConnectionEvents.m_xEventObject,
                                    wifAdviseConnectionProcessed);

  xAddress := m_xListeningSocket.LocalAddress As IdXWAddress;

  lstLog.Items.Add('Listening on ' + xAddress.GetAddressString());
  lblStatus.Caption := 'Listening on ' + xAddress.GetAddressString();

  btStopListening.Enabled := True;
end;

{------------------------------------------------------------------------------}
{ btStopListeningClick: Stop accepting incoming client connections. }

procedure TfrmMain.btStopListeningClick(Sender: TObject);
begin
  btStopListening.Enabled := False;
  lstLog.Items.Add('Stop listening...');

  { Stop listening, and free the listening socket object. }

  m_xListeningSocket.StopListening;
  m_xListeningSocket.ConnectionUnadvise(m_lConnectionCookie);
  m_xListeningSocket.StringTransferUnadvise(m_lStringTransferCookie);
  m_xListeningSocket.FileTransferUnadvise(m_lFileTransferCookie);

  m_xListeningSocket := Nil;

  m_lConnectionCookie := 0;
  m_lStringTransferCookie := 0;
  m_lFileTransferCookie := 0;

  m_nClientsCount := 0;

  lblStatus.Caption := 'Not listening';
  btStartListening.Enabled := True;
  txtPort.Enabled := True;

  lstLog.Items.Add('Stopped listening.');
end;

{------------------------------------------------------------------------------}
{ FormCreate: We create each object we need. }

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  { Create the event handler classes. }

  m_xIncomingConnectionEvents := TIncomingConnectionEvents.Create( Self );
  m_xConnectionEvents := TConnectionEvents.Create( Self );
  m_xStringTransferEvents := TStringTransferEvents.Create( Self );
  m_xFileTransferEvents := TFileTransferEvents.Create( Self );

  { Create the list that will hold THttpRequest items }

  m_lstRequests := TList.Create;

  { Reset other members }

  m_lConnectionCookie := 0;
  m_lStringTransferCookie := 0;
  m_lFileTransferCookie := 0;

  m_nClientsCount := 0;
end;

{------------------------------------------------------------------------------}
{ FormDestroy: The form is being destroyed, we free each instance. }

procedure TfrmMain.FormDestroy(Sender: TObject);
var
  pItem : PHttpRequest;
begin
  m_xListeningSocket := Nil;

  while m_lstRequests.Count > 0 do
  begin
    pItem := m_lstRequests.Items[0];
    m_lstRequests.Remove( pItem );
    Dispose( pItem );
  end;

  m_xIncomingConnectionEvents.Free;
  m_xConnectionEvents.Free;
  m_xStringTransferEvents.Free;
  m_xFileTransferEvents.Free;
end;

{------------------------------------------------------------------------------}
{ OnConnection: Triggered when a connection is about to be made with a client. }

procedure TfrmMain.OnConnection( const xListeningSocket : IDispatch;
                                 const xRemoteAddress : IDispatch;
                                 vaCallerData : OleVariant;
                                 lExpectedCalleeDataSize : Integer;
                                 var vaCalleeData : OleVariant;
                                 var xQualityOfService : IdXWQualityOfServiceInfo;
                                 var lUserParam : Integer;
                                 var bReject : WordBool );
begin
  { We ignore this event. bReject is always false by default. }
end;

{------------------------------------------------------------------------------}
{ OnConnectionProcessed: Triggered when a new connection was successfully made
                         with a client. }

procedure TfrmMain.OnConnectionProcessed( const xListeningSocket : IDispatch;
                                          const xIncomingSocket : IDispatch;
                                          lUserParam : Integer );
var
  xClientSocket : ConnectionOrientedSocket;
  xAddress      : Address;
begin
  { The xIncomingSocket parameter is the connection-oriented socket that is
    associated with this new connected client. Assigning it to a typed
    ConnectionOrientedSocket variable makes it easier to use. }

  xClientSocket := xIncomingSocket As ConnectionOrientedSocket;
  xAddress := xClientSocket.RemoteAddress As Address;

  { Update information displayed on the form. }

  lstLog.Items.Add( 'Client connected: ' + xAddress.GetAddressString );
  lstClients.Items.Add( xAddress.GetAddressString );

  m_nClientsCount := m_nClientsCount + 1;
  lblConnections.Caption := IntToStr( m_nClientsCount ) + ' connected clients';
end;

{------------------------------------------------------------------------------}
{ OnListeningError: Triggered when an error occurs while waiting for incoming
                    connections. }

procedure TfrmMain.OnListeningError( const xListeningSocket : IDispatch;
                                     lUserParam: Integer;
                                     lResultCode: Integer );
begin
  { We ignore this event. }
end;

{------------------------------------------------------------------------------}
{ OnDisconnected: Event triggered when a client socket has disconnected. We
                  remove this connection from our list of pending requests. }

procedure TfrmMain.OnDisconnected( const xSocket : IDispatch;
                                   vaCallerData : OleVariant;
                                   var vaCalleeData : OleVariant );
var
  xClientSocket : ConnectionOrientedSocket;
  xAddress      : Address;
  i             : Integer;
  pItem         : PHttpRequest;
begin
  { The xSocket parameter is the connection-oriented socket that disconnected.
    Assigning it to a typed ConnectionOrientedSocket variable makes it easier
    to use. }

  xClientSocket := xSocket As ConnectionOrientedSocket;
  xAddress      := xClientSocket.RemoteAddress As Address;

  lstLog.Items.Add('Client disconnected: ' + xAddress.GetAddressString);

  { Locate the client's address in the list of connected clients, and remove it. }

  For i := 0 To lstClients.Items.Count - 1 do
    If lstClients.Items[i] = xAddress.GetAddressString Then
    begin
      lstClients.Items.Delete(i);
      break;
    end;

  { Locate the connection-oriented socket in the list of resquests and remove it. }

  For i := 0 To m_lstRequests.Count - 1 do
  begin
    pItem := PHttpRequest( m_lstRequests.Items[i] );
    if xSocket As IUnknown = pItem^.m_xConnection As IUnknown then
    begin
      m_lstRequests.Remove( pItem );
      Dispose( pItem );
      break;
    end;
  end;

  m_nClientsCount := m_nClientsCount - 1;
  lblConnections.Caption := IntToStr( m_nClientsCount) + ' connected clients';
end;

{------------------------------------------------------------------------------}
{ OnStringSent: Triggered when a call to AsyncSendString completes. }

procedure TfrmMain.OnStringSent( const xSocket : IDispatch;
                                 lUserParam : Integer;
                                 lResultCode : Integer );
begin
  { We ignore this event. }
end;

{------------------------------------------------------------------------------}
{ OnStringReceived: Triggered when a call to AsyncReceiveString or
                    AsyncReceiveLine completed, or when you advised to receive
                    all data as it arrives on the wire. This is where we
                    receive HTTP requests. Remember that they may not be
                    complete. }

procedure TfrmMain.OnStringReceived( const xSocket : IDispatch;
                                     const sString : WideString;
                                     lUserParam : Integer;
                                     lResultCode: Integer );
var
  xClientSocket : ConnectionOrientedSocket;
  i             : Integer;
  pItem         : PHttpRequest;
  xAddress      : Address;
begin
  { The xSocket parameter is the connection-oriented socket that is associated
    with this connected client. Assigning it to a typed ConnectionOrientedSocket
    variable makes it easier to use. }

  xClientSocket := xSocket As ConnectionOrientedSocket;

  pItem := Nil;

  for i := 0 to m_lstRequests.Count - 1 do
  begin
    pItem := m_lstRequests.Items[i];

    if pItem^.m_xConnection As IUnknown = xSocket As IUnknown then
      break;

    pItem := Nil;
  end;

  If not Assigned( pItem ) Then
  begin
    { Create a new THttpRequest }
    New( pItem );
    pItem^.m_xConnection  := xClientSocket;
    m_lstRequests.Add( pItem );
  end;

  AppendRequestString( pItem, sString );

  if IsRequestComplete( pItem ) then
  begin
    xAddress := xClientSocket.RemoteAddress As Address;
    lstLog.Items.Add( 'HTTP request received from client ' + xAddress.GetAddressString );
    lstLog.Items.Add( '  --> ' + pItem^.m_sRequest );

    lstLog.Items.Add( 'Sending file ' + GetRelativeFilename( pItem ) + ' to ' + xAddress.GetAddressString );
    xClientSocket.AsyncSendFile( GetAbsoluteFilename( pItem ), 0, 0, 0 );
  end;
end;

{------------------------------------------------------------------------------}
{ OnStringAvailable: Triggered when new data is available in the library's
                     internal buffers. }

procedure TfrmMain.OnStringAvailable( const xSocket : IDispatch;
                                      lCharsReceived : Integer;
                                      lCharsAvailable : Integer );
begin
  { We ignore this event. }
end;

{------------------------------------------------------------------------------}
{ OnOutOfBandStringReceived: Triggered when out-of-band data is received and
                             advised to receive such data with the
                             wsaAdviseOutOfBandReceivedAlways flag. }

procedure TfrmMain.OnOutOfBandStringReceived( const xSocket: IDispatch;
                                              const sString: WideString;
                                              lResultCode: Integer );
begin
  { We ignore this event. }
end;

{------------------------------------------------------------------------------}
{ OnFileSent: Triggered when a portion of a file, or all the file was sent,
              depending if you advised to receive this event only when the
              file is completely sent. }

procedure TfrmMain.OnFileSent( const xSocket : IDispatch;
                               const sFilename : WideString;
                               lStartOffset : Integer;
                               lBytesSent : Integer;
                               lBytesTotal : Integer;
                               lUserParam : Integer;
                               bTransferCompleted : WordBool;
                               lResultCode: Integer );
begin
  if bTransferCompleted then
  begin
    { The xSocket parameter is the connection-oriented socket that is associated
      with this connected client. Assigning it to a typed ConnectionOrientedSocket
      variable makes it easier to use. }

    { When we're done sending the file, we disconnect.}

    ( xSocket As ConnectionOrientedSocket ).Disconnect;
  end;
end;

{------------------------------------------------------------------------------}
{ OnFileReceived: Triggered when a portion of a file, or all the file was
                  received, depending if you advised to receive this event only
                  when the file is completely received. }

procedure TfrmMain.OnFileReceived( const xSocket : IDispatch;
                                   const sFilename : WideString;
                                   lStartOffset : Integer;
                                   lBytesReceived : Integer;
                                   lBytesTotal : Integer;
                                   lUserParam : Integer;
                                   bTransferCompleted : WordBool;
                                   lResultCode : Integer );
begin
  { We ignore this event. }
end;

end.