fpc's httpserver and httpclient support provided by Michael Van Canneyt.

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@1640 8e941d3f-bd1b-0410-a28a-d453659cc2b4

wst/trunk/fpc_http_protocol.pas

@@ -0,0 +1,219 @@
+{
+    This file is part of the Web Service Toolkit
+    Copyright (c) 2006 by Inoussa OUEDRAOGO
+
+    This file is provide under modified LGPL licence
+    ( the files COPYING.modifiedLGPL and COPYING.LGPL).
+
+
+    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.
+}
+{$INCLUDE wst_global.inc}
+unit fpc_http_protocol;
+
+//{$DEFINE WST_DBG}
+
+interface
+
+uses
+  Classes, SysUtils,{$IFDEF WST_DBG}Dialogs,{$ENDIF}
+  wst_types, service_intf, imp_utils, base_service_intf, client_utils,
+  fphttpclient;
+
+Const
+  sTRANSPORT_NAME = 'HTTP';
+
+Type
+
+  { TFPCCookieManager }
+
+  TFPCCookieManager = class(TInterfacedObject,ICookieManager)
+  private
+    FReferencedObject : TStrings;
+  protected
+    property ReferencedObject : TStrings read FReferencedObject;
+  protected  
+    function GetCount() : Integer;
+    function GetName(const AIndex : Integer) : string;
+    function GetValue(const AIndex : Integer) : string; overload;
+    function GetValue(const AName : string) : string; overload;
+    procedure SetValue(const AIndex : Integer; const AValue : string); overload;
+    procedure SetValue(const AName : string; const AValue : string); overload;
+  public
+    constructor Create(AReferencedObject : TStrings);
+  end;
+  
+{$M+}
+  { THTTPTransport }
+  THTTPTransport = class(TBaseTransport,ITransport)
+  Private
+    FConnection : TFPHTTPClient;
+    FAddress : string;
+    FFormat : string;
+    FSoapAction: string;
+    FCookieManager : ICookieManager; 
+  private  
+    function GetAddress: string;
+    function GetContentType: string;
+    procedure SetAddress(const AValue: string);
+    procedure SetContentType(const AValue: string);
+  Public
+    constructor Create();override;
+    destructor Destroy();override;      
+    function GetTransportName() : string; override;
+    procedure SendAndReceive(ARequest,AResponse:TStream); override;
+    function GetCookieManager() : ICookieManager; override;
+  Published
+    property ContentType : string Read GetContentType Write SetContentType;
+    property Address : string Read GetAddress Write SetAddress;
+    property SoapAction : string read FSoapAction write FSoapAction;
+    property Format : string read FFormat write FFormat;
+  End;
+{$M+}
+
+  procedure FPC_RegisterHTTP_Transport();
+
+implementation
+uses
+  wst_consts;
+
+{ THTTPTransport }
+
+function THTTPTransport.GetAddress: string;
+begin
+  Result := FAddress;
+end;
+
+function THTTPTransport.GetContentType: string;
+begin
+  Result := FConnection.GetHeader('Content-type');
+end;
+
+procedure THTTPTransport.SetAddress(const AValue: string);
+begin
+  FAddress := AValue;
+end;
+
+procedure THTTPTransport.SetContentType(const AValue: string);
+begin
+  FConnection.AddHeader('Content-type',AValue);
+end;
+
+constructor THTTPTransport.Create();
+begin
+  inherited Create();
+  FConnection:=TFPHTTPClient.Create(Nil);
+  FConnection.HTTPVersion := '1.1';
+end;
+
+destructor THTTPTransport.Destroy();
+begin
+  FreeAndNil(FConnection);
+  inherited Destroy();
+end;
+
+function THTTPTransport.GetTransportName() : string;  
+begin
+  Result := sTRANSPORT_NAME;
+end;
+
+procedure THTTPTransport.SendAndReceive(ARequest, AResponse: TStream);
+
+var
+  EMsg : String;
+  req,resp : TStream;
+  
+begin
+  If not HasFilter then
+    begin
+    Req:=ARequest;
+    Resp:=AResponse;
+    end
+  else      
+    begin
+    Req:=TMemoryStream.Create();
+    Resp:=TMemoryStream.Create();
+    end;
+  try
+    if HasFilter then
+      FilterInput(ARequest,req);  
+    try
+      Req.position:=0;
+      FConnection.RequestBody:=Req;
+      FConnection.Post(FAddress,Resp);
+      if HasFilter then
+        FilterOutput(Resp,AResponse);
+    except
+      On E : Exception do
+      EMsg:=E.Message;
+    end;
+    if (EMsg<>'') then
+      raise ETransportExecption.CreateFmt(SERR_FailedTransportRequest,[sTRANSPORT_NAME,FAddress]);
+  finally
+    if Req<>ARequest then
+      Req.Free;
+    if Resp<>AResponse then
+      Resp.Free;
+  end;
+end;
+
+function THTTPTransport.GetCookieManager() : ICookieManager; 
+begin
+  if (FCookieManager=nil) then
+    FCookieManager:=TFPCCookieManager.Create(FConnection.Cookies);
+  Result:=FCookieManager;
+end;
+
+procedure FPC_RegisterHTTP_Transport();
+begin
+  GetTransportRegistry().Register(sTRANSPORT_NAME,TSimpleItemFactory.Create(THTTPTransport) as IItemFactory);
+end;
+
+{ TFPCCookieManager }
+
+function TFPCCookieManager.GetCount() : Integer; 
+begin
+  Result := ReferencedObject.Count;
+end;
+
+function TFPCCookieManager.GetName(const AIndex : Integer) : string; 
+begin
+  Result := ReferencedObject.Names[AIndex];
+end;
+
+function TFPCCookieManager.GetValue(const AIndex : Integer) : string; 
+begin
+  Result := ReferencedObject.ValueFromIndex[AIndex];
+end;
+
+function TFPCCookieManager.GetValue(const AName : string) : string; 
+begin
+  Result := ReferencedObject.Values[AName];
+end;
+
+procedure TFPCCookieManager.SetValue(
+  const AIndex : Integer;  
+  const AValue : string
+); 
+begin
+  ReferencedObject.ValueFromIndex[AIndex] := AValue;
+end;
+
+procedure TFPCCookieManager.SetValue(
+  const AName : string;  
+  const AValue : string
+); 
+begin
+  ReferencedObject.Values[AName] := AValue;
+end;
+
+constructor TFPCCookieManager.Create(AReferencedObject : TStrings); 
+begin
+  if (AReferencedObject = nil) then
+    raise ETransportExecption.CreateFmt(SERR_InvalidParameter,['AReferencedObject']); 
+  FReferencedObject := AReferencedObject;
+end;
+
+end.

wst/trunk/fpc_http_server.pas

@@ -0,0 +1,242 @@
+{
+    This file is part of the Web Service Toolkit
+    Copyright (c) 2006 by Inoussa OUEDRAOGO
+
+    This file is provide under modified LGPL licence
+    ( the files COPYING.modifiedLGPL and COPYING.LGPL).
+
+
+    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.
+}
+
+{$INCLUDE wst_global.inc}
+
+unit fpc_http_server;
+
+interface
+
+uses
+  Classes, SysUtils, httpdefs, fphttpserver, server_listener, wst_types;
+
+type
+
+  { TwstFPHttpListener }
+
+  TwstFPHttpListener = class(TwstListener)
+  private
+    FHTTPServerObject: TFPHTTPServer;
+    FRootAddress : string;
+    FServerSoftware : String;
+  private
+    procedure ProcessWSDLRequest(
+          ARequest  : TRequest;
+          AResponse : TResponse;
+      var APath     : string
+    );
+    procedure ProcessServiceRequest(
+          ARequest  : TRequest;
+          AResponse : TResponse;
+      var APath     : string
+    );
+  private
+    procedure RequestHandler(Sender: TObject; 
+                Var ARequest: TFPHTTPConnectionRequest;
+                Var AResponse : TFPHTTPConnectionResponse);
+  public
+    constructor Create(
+      const AServerIpAddress   : string  = '127.0.0.1';
+      const AListningPort      : Integer = 8000;
+      const ADefaultClientPort : Integer = 25000;
+      const AServerSoftware    : string  = 'Web Service Toolkit Application'
+    );
+    destructor Destroy(); override;
+    class function GetDescription() : string;override;
+    procedure Start();override;
+    procedure Stop();override;
+    function IsActive : Boolean; override;
+  end;
+
+
+implementation
+uses
+  base_service_intf, server_service_intf, server_service_imputils, metadata_wsdl;
+
+{$IFDEF WST_DBG}
+procedure Display(const AMsg : string);
+begin
+  if IsConsole then
+    WriteLn(AMsg);
+end;
+{$ENDIF}
+
+function ExtractNextPathElement(var AFullPath : string):string;
+var
+  i : SizeInt;
+begin
+  Result := '';
+  if ( Length(AFullPath) > 0 ) then begin
+    while ( Length(AFullPath) > 0 ) and ( AFullPath[1] = sSEPARATOR ) do begin
+      Delete(AFullPath,1,1);
+    end;
+    i := Pos(sSEPARATOR,AFullPath);
+    if ( i < 1 ) then begin
+      Result := AFullPath;
+      AFullPath := '';
+    end else begin
+      Result := Copy(AFullPath,1,Pred(i));
+      Delete(AFullPath,1,i);
+    end;
+  end;
+end;
+
+{ TwstFPHttpListener }
+
+procedure TwstFPHttpListener.ProcessWSDLRequest(
+      ARequest  : TRequest;
+      AResponse : TResponse;
+  var APath     : string
+);
+var
+  locRepName, strBuff : string;
+  i : Integer;
+begin
+  locRepName := ExtractNextPathElement(APath);
+  if AnsiSameText(sWSDL,locRepName) then
+    locRepName := ExtractNextPathElement(APath);
+  strBuff := GenerateWSDL(locRepName,FRootAddress);
+  i:=Length(strBuff);
+  if (StrBuff<>'') then 
+    begin
+    AResponse.ContentType := 'text/xml';
+    AResponse.Content:=strBuff;
+    end
+  else
+    begin  
+    AResponse.ContentType := 'text/html';
+    AResponse.Content := GenerateWSDLHtmlTable();
+    end;
+  if AResponse.ContentLength=0 then  
+    AResponse.ContentLength:=Length(AResponse.Content);  
+end;
+
+procedure TwstFPHttpListener.ProcessServiceRequest(
+      ARequest  : TRequest;
+      AResponse : TResponse;
+  var APath     : string
+);
+var
+  trgt,ctntyp, frmt : string;
+  rqst : IRequestBuffer;
+  inStream : TStringStream;
+begin
+  trgt := ExtractNextPathElement(APath);
+  if AnsiSameText(sWSDL,trgt) then 
+    begin
+    ProcessWSDLRequest(ARequest,AResponse,APath);
+    Exit;
+    end;
+  inStream := nil;
+  try
+    inStream := TStringStream.Create(ARequest.Content);
+    try
+      AResponse.ContentStream := TMemoryStream.Create();
+      ctntyp := ARequest.ContentType;
+      AResponse.ContentType := ctntyp;
+      frmt := Trim(ARequest.QueryFields.Values['format']);
+      rqst := TRequestBuffer.Create(trgt,ctntyp,inStream,AResponse.ContentStream,frmt);
+      rqst.GetPropertyManager().SetProperty(sREMOTE_IP,ARequest.RemoteAddress);
+      HandleServiceRequest(rqst);
+      AResponse.ContentLength:=AResponse.ContentStream.Size;
+    finally
+      inStream.Free();
+    end;
+  except
+    on e : Exception do begin
+      NotifyMessage('ProcessData()>> Exception = '+e.Message);
+      raise;
+    end;
+  end;
+end;
+
+procedure TWstFPHttpListener.RequestHandler(Sender: TObject; 
+                Var ARequest: TFPHTTPConnectionRequest;
+                Var AResponse : TFPHTTPConnectionResponse);
+
+var
+{$IFDEF WST_DBG}
+  s : string;
+  j : SizeInt;
+{$ENDIF}
+  locPath, locPathPart : string;
+begin
+  AResponse.Server:=FServerSoftware;
+  locPath := ARequest.URL;
+  locPathPart := ExtractNextPathElement(locPath);
+  if AnsiSameText(sSERVICES_PREFIXE,locPathPart)  then 
+    ProcessServiceRequest(ARequest,AResponse,locPath)
+  else
+    ProcessWSDLRequest(ARequest,AResponse,locPath);
+  try
+    AResponse.SendContent;
+  finally  
+    If Assigned(AResponse.ContentStream) then
+      begin
+      AResponse.ContentStream.Free;
+      AResponse.ContentStream:=Nil;
+      end;
+  end;  
+end;
+
+constructor TwstFPHttpListener.Create(
+      const AServerIpAddress   : string;
+      const AListningPort      : Integer;
+      const ADefaultClientPort : Integer;
+      const AServerSoftware    : string
+);
+
+begin
+  inherited Create();
+  FHTTPServerObject := TFPHTTPServer.Create(nil);
+//  b.IP := AServerIpAddress;
+  FHTTPServerObject.port := AListningPort;
+  FRootAddress := Format('http://%s:%d/',[AServerIpAddress,AListningPort]);
+  FServerSoftware := AServerSoftware;
+  FHTTPServerObject.OnRequest := @RequestHandler;
+end;
+
+destructor TwstFPHttpListener.Destroy();
+begin
+  if ( FHTTPServerObject <> nil ) then
+    Stop();
+  FreeAndNil(FHTTPServerObject);
+  inherited Destroy();
+end;
+
+procedure TwstFPHttpListener.Start();
+begin
+  if not FHTTPServerObject.Active then
+    FHTTPServerObject.Active := True;
+end;
+
+procedure TwstFPHttpListener.Stop();
+begin
+  if FHTTPServerObject.Active then
+    FHTTPServerObject.Active := False;
+end;
+
+class function TwstFPHttpListener.GetDescription: string;
+begin
+  Result := 'WST FP HTTP Listener';
+end;
+
+function TwstFPHttpListener.IsActive: Boolean;
+begin
+  Result := FHTTPServerObject.Active;
+end;
+
+initialization
+
+
+end.