wsdlpub.pas

delphi7 webservice soap 补丁

{***************************************************************}
{                                                               }
{   Borland Delphi Visual Component Library                     }
{                                                               }
{   Copyright (c) 2000-2001 Borland Software Corporation        }
{                                                               }
{***************************************************************}
unit WSDLPub;

{$IFNDEF VER150}
{$INCLUDE 'CompVer.inc'}
{$ENDIF}

interface

uses InvokeRegistry, Classes, HTTPApp, AutoDisp, Masks, Types,
     WebServExp;

type

  IWSDLPublish = interface(IInvokable)
  ['{ECD820DD-F242-11D4-928A-00C04F990435}']
    function  GetPortTypeList: TWideStringDynArray; stdcall;
    function  GetWSDLForPortType(const PortType: WideString): WideString; stdcall;
    function  GetTypeSystemsList: TWideStringDynArray; stdcall;
    function  GetXSDForTypeSystem(const TypeSystem: WideString): WideString; stdcall;
  end;

  TBeforePublishingWSDLEvent = procedure(const IntfName: WideString; var WSDL: WideString; var Handled: Boolean) of object;

  TWSDLPublish = class(TInvokableClass, IWSDLPublish)
  private
    Locations: array of WideString;
    PortNames: array of WideString;
    FTargetNamespace: WideString;

    FOnBeforePublishingWSDL: TBeforePublishingWSDLEvent;
    FOnBeforePublishingTypes: TBeforePublishingTypesEvent;
    FOnPublishingType: TPublishingTypeEvent;
    FOnAfterPublishingWSDL: TAfterPublishingWSDLEvent;
  public
    property  TargetNamespace: WideString read FTargetNamespace write FTargetNamespace;
    procedure GetPortTypeEntries(var Entries: TInvRegIntfEntryArray);

    { IWSDLPublish }
    function  GetPortTypeList: TWideStringDynArray; stdcall;
    function  GetWSDLForPortType(const PortType: WideString): WideString; stdcall;
    function  GetTypeSystemsList: TWideStringDynArray; stdcall;
    function  GetXSDForTypeSystem(const TypeSystem: WideString): WideString; stdcall;

    property OnBeforePublishingWSDL: TBeforePublishingWSDLEvent read FOnBeforePublishingWSDL write FOnBeforePublishingWSDL;
    property OnBeforePublishingTypes: TBeforePublishingTypesEvent read FOnBeforePublishingTypes write FOnBeforePublishingTypes;
    property OnPublishingType: TPublishingTypeEvent read FOnPublishingType write FOnPublishingType;
    property OnAfterPublishingWSDL: TAfterPublishingWSDLEvent read FOnAfterPublishingWSDL write FOnAfterPublishingWSDL;
  end;

  SOAPPublishOptions = (poDefault, poPublishLocationAsSecure);
  TSOAPPublishOptions= set of SOAPPublishOptions;

  TWSDLHTMLPublish =  class(TComponent, IWebDispatch)
  private
    Pub: TWSDLPublish;
    FWebDispatch: TWebDispatch;
    FAdminEnabled: Boolean;
    FTargetNamespace: WideString;
    FPublishOptions: TSOAPPublishOptions;
    FOnBeforePublishingWSDL: TBeforePublishingWSDLEvent;
    FOnBeforePublishingTypes: TBeforePublishingTypesEvent;
    FOnPublishingType: TPublishingTypeEvent;
    FOnAfterPublishingWSDL: TAfterPublishingWSDLEvent;
    procedure SetWebDispatch(const Value: TWebDispatch);
{$IFDEF DIAMONDBACK_UP}
    function GetNameSpaceIsStored:Boolean;
{$ENDIF}
  protected
    procedure AddInterfaceList(htmldoc: TStringList; const WSDLBaseURL: String);
    procedure AddPortList(htmldoc: TStringList; const PortType: String);
    procedure UpdatePortList(PortList: TStrings; const PortType, Command: String);
    function  GetHostScriptBaseURL(Request: TWebRequest): String;
    procedure WSILInfo(const HostScriptBaseURL: string; Request: TWebRequest;
                Response: TWebResponse; var Handled: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { IWebDispatch }
    function DispatchEnabled: Boolean;
    function DispatchMask: TMask;
    function DispatchMethodType: TMethodType;
    function DispatchRequest(Sender: TObject; Request: TWebRequest;
      Response: TWebResponse): Boolean;
    procedure ServiceInfo(Sender: TObject; Request: TWebRequest;
                Response: TWebResponse; var Handled: Boolean);
    function HandleRequest(Resp: TStringList; const Path: String;
                           const HostScriptBaseURL: String;
                           var ContentType: String; Request: TWebRequest): integer;
    function GetTargetNamespace: WideString;
  published
    property WebDispatch: TWebDispatch read FWebDispatch write SetWebDispatch;
{$IFDEF DIAMONDBACK_UP}
    property AdminEnabled: Boolean read FAdminEnabled write FAdminEnabled default False;
    property TargetNamespace: WideString read GetTargetNamespace write FTargetNamespace stored GetNameSpaceIsStored;
    property PublishOptions: TSOAPPublishOptions read FPublishOptions write FPublishOptions default [];
{$ELSE}
    property AdminEnabled: Boolean read FAdminEnabled write FAdminEnabled;
    property TargetNamespace: WideString read GetTargetNamespace write FTargetNamespace;
    property PublishOptions: TSOAPPublishOptions read FPublishOptions write FPublishOptions;
{$ENDIF}
    property OnBeforePublishingWSDL: TBeforePublishingWSDLEvent read FOnBeforePublishingWSDL write FOnBeforePublishingWSDL;
    property OnBeforePublishingTypes: TBeforePublishingTypesEvent read FOnBeforePublishingTypes write FOnBeforePublishingTypes;
    property OnPublishingType: TPublishingTypeEvent read FOnPublishingType write FOnPublishingType;
    property OnAfterPublishingWSDL: TAfterPublishingWSDLEvent read FOnAfterPublishingWSDL write FOnAfterPublishingWSDL;
  end;

  procedure WSDLPubFactory(out obj: TObject);

implementation

uses {$IFDEF MSWINDOWS}Windows, ActiveX, {$ENDIF}
  SysUtils, IntfInfo, XMLSchema, WSDLIntf, WSDLBind, TypInfo,
  WSDLItems, WSDLSOAP, IniFiles, OPToSOAPDomConv, SOAPConst, WSILIntf;

resourcestring
  sPortNameHeader = 'PortName';
  sAddressHeader = 'address';
  sAdminButtonCation = 'Administrator';
  sAddButtonCaption = 'Add';
  sDeleteButtonCaption = 'Remove';

{ TWSDLPublish }

var
  AdminIniFile: string;
  ServicePath: string;
  ServiceName: string;
  ModuleName: array[0..MAX_PATH] of char;


procedure AddElem(htmldoc: TStringList; const Elem: string; const cls: string);
begin
  htmldoc.Add('<td class="'+cls+'">' + Elem + '</td>');   { Do not localize }
end;

procedure TWSDLHTMLPublish.AddInterfaceList(htmldoc: TStringList; const WSDLBaseURL: String);
var
  I: Integer;
  Entries: TInvRegIntfEntryArray;
  Entry: InvRegIntfEntry;
  Doc: string;
begin
  htmldoc.Add('<table ' + TableStyle + '>');        { Do not localize }
  htmldoc.Add('<tr>');                              { Do not localize }
  AddElem(htmldoc, sPortType, sTblHdrCls);
  AddElem(htmldoc, sNamespaceURI, sTblHdrCls);
  AddElem(htmldoc, sDocumentation, sTblHdrCls);
  AddElem(htmldoc, sWSDL, sTblHdrCls);
  htmldoc.Add('</tr>');
  Pub.GetPortTypeEntries(Entries);
  for I := 0 to Length(Entries) - 1 do
  begin
    Entry := Entries[I];
    htmldoc.Add('<tr>');                  { Do not localize }
    AddElem(htmldoc, Entry.Name, sTblRow);
    AddElem(htmldoc, Entry.Namespace, sTblRow);
    Doc := Entry.Documentation;
    if Doc = '' then
      Doc := sNBSP;
    AddElem(htmldoc, Doc, sTblRow);
    AddElem(htmldoc, '<a href="' + WSDLBaseURL + '/' + Entry.Name + '">' + sWSDLFor + Entry.Name + '</a>', sTblRow); { Do not localize }
    htmldoc.Add('</tr>');                 { Do not localize }
  end;
  htmldoc.Add('</table>');                { Do not localize }
end;

procedure TWSDLHTMLPublish.AddPortList(htmldoc: TStringList; const PortType: string);
var
  I: Integer;
  IniFile: TMemIniFile;
  PortList: TStringList;
begin
  IniFile := TMemIniFile.Create(AdminIniFile);
  try
    htmldoc.Add('<table ' + TableStyle + '>');  { Do not localize }
    htmldoc.Add('<tr>');                        { Do not localize }
    AddElem(htmldoc, sPortNameHeader, sTblHdrCls);
    AddElem(htmldoc, sAddressHeader, sTblHdrCls);
    htmldoc.Add('</tr>');                       { Do not localize }
    if IniFile.SectionExists(PortType) then
    begin
      PortList := TStringList.Create;
      try
        IniFile.ReadSectionValues(PortType, PortList);
        for I := 0 to PortList.Count - 1 do
        begin
          htmldoc.Add('<tr>');                  { Do not localize }
          AddElem(htmldoc, PortList.Names[I], sTblRow);
          AddElem(htmldoc, PortList.Values[PortList.Names[I]], sTblRow);
          htmldoc.Add('</tr>');                 { Do not localize }
        end;
      finally
        PortList.Free;
      end;
    end;
    htmldoc.Add('</table>');
  finally
    IniFile.Free;
  end;
end;

procedure TWSDLHTMLPublish.UpdatePortList(PortList: TStrings; const PortType, Command: String);
var
  IniFile: TMemIniFile;
begin
  if PortList.Count > 0 then
  begin
    IniFile := TMemIniFile.Create(AdminIniFile);
    try
      if PortList.Values['PortName'] <> '' then     { Do not localize }
        if UpperCase(Command) = 'ADD' then          { Do not localize }
          IniFile.WriteString(PortType, PortList.Values[sPortName], PortList.Values[sAddress])
        else if UpperCase(Command) = 'REMOVE' then  { Do not localize }
          IniFile.DeleteKey(PortType, PortList.Values[sPortName]);
      if AdminEnabled then
        IniFile.UpdateFile;
    finally
      IniFile.Free;
    end;
  end;
end;

function TWSDLHTMLPublish.GetHostScriptBaseURL(Request: TWebRequest): String;
begin
 { Here we set the proper url prefix and port [if nessecary] }
  if poPublishLocationAsSecure in PublishOptions then begin // SSL
    if (Request.ServerPort <> 443) and (Pos(':', Request.Host) = 0) then
      Result := 'https://' + Request.Host + ':' + IntToStr(Request.ServerPort) + Request.InternalScriptName         { do not localize }
    else
      Result := 'https://' + Request.Host + Request.InternalScriptName;    { do not localize }
  end else begin                                            // Normal
    if (Request.ServerPort <> 80) and (Pos(':', Request.Host) = 0) then
      Result := 'http://' + Request.Host + ':' + IntToStr(Request.ServerPort) + Request.InternalScriptName         { do not localize }
    else
      Result := 'http://' + Request.Host + Request.InternalScriptName;    { do not localize }
  end;

end;

function TWSDLPublish.GetPortTypeList: TWideStringDynArray;
var
  I, Count: Integer;
  IntfEntry: InvRegIntfEntry;
begin
  { Use invrg to list all the interfaces registered, add new method if necessary }
  Count := InvRegistry.GetInterfaceCount;
  SetLength(Result, Count);
  for I:= 0 to Count-1 do
  begin
    IntfEntry := InvRegistry.GetRegInterfaceEntry(I);
    Result[I] := IntfEntry.Name;
  end;
end;

function TWSDLPublish.GetTypeSystemsList: TWideStringDynArray;
var
  I, Count: Integer;
  URIMap: TRemRegEntry;
  TypeSystemList: TWideStrings;
begin
  TypeSystemList := TWideStrings.Create;
  try
    { Find Unique URIs registered }
    Count := RemClassRegistry.GetURICount;
    for I := 0 to Count-1 do
    begin
      URIMap := RemClassRegistry.GetURIMap(I);
      if TypeSystemList.IndexOf(URIMap.URI) = -1 then
        TypeSystemList.Add(URIMap.URI)
    end;
    SetLength(Result, TypeSystemList.Count);
    for I := 0 to TypeSystemList.Count-1 do
      Result[I] := TypeSystemList[I];
  finally
    TypeSystemList.Free;
  end;
end;

function TWSDLPublish.GetWSDLForPortType(const PortType: WideString): WideString;
var
  IID: TGUID;
  Info: PTypeInfo;
  WSDLDoc: IWSDLDocument;
  WebServExp: TWebServExp;
  WebServIntf: IWebServExp;
  SResult: string;
  Handled: Boolean;
begin
  { Allow user first crack }
  if Assigned(FOnBeforePublishingWSDL) then
  begin
    Handled := False;
    Result := '';
    FOnBeforePublishingWSDL(PortType, Result, Handled);
    if Handled then
      Exit;
  end;
  { Use invrg to get typeinfo for porttype name ( interface name ) }
  { Convert to WSDL fragement }
  InvRegistry.GetInterfaceInfoFromName ('', PortType, Info, IID);

  { TODO Should we throw an exception if interface is not registered?? }
  if Info <> nil then
  begin
    WSDLDoc := TWSDLDocument.Create(nil);
    WSDLDoc.Active := True;
    WebServIntf := TWebServExp.Create;
    WebServExp := (WebServIntf as IWebServExpAccess).GetWebServExp;

    WebServExp.TargetNameSpace := TargetNamespace;
    WSDLDoc.Encoding := 'utf-8';        { Do not localize }
    WebServExp.BindingType := btSoap;
    WebServExp.WSDLElements :=  WebServExp.WSDLElements + [weService];

    WebServExp.OnBeforePublishingTypes := FOnBeforePublishingTypes;
    WebServExp.OnPublishingType := FOnPublishingType;
    WebServExp.OnAfterPublishingWSDL := FOnAfterPublishingWSDL;

    WebServExp.GetWSDLForInterface(Info, WSDLDoc, PortNames, Locations);
    WSDLDoc.SaveToXML(SResult);
    Result := SResult;
  end;
end;

function TWSDLPublish.GetXSDForTypeSystem(const TypeSystem: WideString): WideString;
var
  I, Count: Integer;
  URIMap: TRemRegEntry;
  WebServExp: TWebServExp;
  XMLDoc: IXMLSchemaDoc;
  SResult: string;
begin
  { Use xsdclasses to get list of all classes registered with same URI and }
  { Create XML schema doc for this. }
  Count := RemClassRegistry.GetURICount;
  for I := 0 to Count -1 do
  begin
    URIMap := RemClassRegistry.GetURIMap(I);
    if TypeSystem = URIMap.URI then
    begin
      WebServExp := TWebServExp.Create;
      try
        XMLDoc := NewXMLSchema;
        WebServExp.GenerateXMLSchema(XMLDoc.SchemaDef, URIMap.Info, nil, '');
        XMLDoc.SaveToXML(SResult);
        Result := SResult;
      finally
        WebServExp.Free;
      end;
    end;
  end;
end;