{***************************************************************} { } { Borland Delphi Visual Component Library } { } { Copyright (c) 2000-2001 Borland Software Corporation } { } {***************************************************************} unit WSDLPubGrendel; // Modified ServiceName declaration for Grendel WebService // $Id: WSDLPubGrendel.pas,v 1.1 2003/12/12 13:19:57 druid Exp $ 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); 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; property AdminEnabled: Boolean read FAdminEnabled write FAdminEnabled; property TargetNamespace: WideString read GetTargetNamespace write FTargetNamespace; property PublishOptions: TSOAPPublishOptions read FPublishOptions write FPublishOptions; 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 automatically detect the default HTTPS port [sure hope no one dares to use 443 for non SSL purposes] or if user configured publisher to publish service location as SSL } if (Request.ServerPort = 443) or (poPublishLocationAsSecure in PublishOptions) then Result := 'https://' + Request.Host + Request.InternalScriptName { do not localize } else 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; 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; procedure WSDLPubFactory(out obj: TObject); begin obj := TWSDLPublish.Create; end; procedure TWSDLPublish.GetPortTypeEntries(var Entries: TInvRegIntfEntryArray); var I, J, Count, AllIntf: Integer; Entry: InvRegIntfEntry; begin AllIntf := InvRegistry.GetInterfaceCount; Count := 0; for I := 0 to AllIntf do begin if InvRegistry.HasRegInterfaceImpl(I) then Inc(Count); end; SetLength(Entries, Count); J := 0; for I:= 0 to AllIntf-1 do begin { Skip non-implemented classes } if not InvRegistry.HasRegInterfaceImpl(I) then continue; { Put the built-in publisher last } Entry := InvRegistry.GetRegInterfaceEntry(I); if Entry.Info = TypeInfo(IWSDLPublish) then Entries[Count-1] := Entry else begin Entries[J] := Entry; Inc(J); end; end; end; { TWSDLHTMLPublish } constructor TWSDLHTMLPublish.Create(AOwner: TComponent); begin inherited Create(AOwner); FWebDispatch := TWebDispatch.Create(Self); FWebDispatch.PathInfo := 'wsdl*'; FWebDispatch.MethodType := mtAny; end; destructor TWSDLHTMLPublish.Destroy; begin inherited Destroy; FWebDispatch.Free; end; function TWSDLHTMLPublish.DispatchEnabled: Boolean; begin Result := True; end; function TWSDLHTMLPublish.DispatchMask: TMask; begin Result := FWebDispatch.Mask; end; function TWSDLHTMLPublish.DispatchMethodType: TMethodType; begin Result := FWebDispatch.MethodType; end; function TWSDLHTMLPublish.HandleRequest(Resp: TStringList; const Path: String; const HostScriptBaseURL: String; var ContentType: String; Request: TWebRequest): integer; var Pub: TWSDLPublish; procedure AddAdmin(const URL: string); begin Resp.Add('<FORM NAME="admin" METHOD="GET" ACTION=' + '"' + URL + '"' + '>'); { do not localize } Resp.Add('<INPUT TYPE="SUBMIT" VALUE="' + sAdminButtonCation + '">'); Resp.Add('</FORM>'); { do not localize } end; function getDefaultPortValue(Name: string): string; begin Result := HostScriptBaseURL + '/soap/' + Name; { Do not localize } end; function getDefaultPortKey(Name: string): string; begin Result := Name + 'Port'; { Do not localize } end; procedure CreateDefaultEntries; var I: Integer; Entries: TInvRegIntfEntryArray; IniFile: TMemIniFile; begin if not FileExists(AdminIniFile) then begin IniFile := TMemIniFile.Create(AdminIniFile); try Pub.GetPortTypeEntries(Entries); for I := 0 to Length(Entries) - 1 do with Entries[I] do IniFile.WriteString(Name, getDefaultPortKey(Name), getDefaultPortValue(Name)); { do not localize } if AdminEnabled then IniFile.UpdateFile; finally IniFile.Free; end; end; end; procedure NewServicePortForm; begin Resp.Add('<FORM NAME="admin" METHOD="GET" ACTION=' + '"' + { do not localize } HostScriptBaseURL + Path + '"' + '>'); { do not localize } Resp.Add('<table ' + TableStyle + '>'); { do not localize } Resp.Add('<tr>'); { do not localize } AddElem(Resp, sPortNameHeader, sTblHdrCls); AddElem(Resp, sAddressHeader, sTblHdrCls); Resp.Add('</tr>'); { do not localize } Resp.Add('<tr>'); { do not localize } AddElem(Resp, '<INPUT TYPE="TEXT" NAME="' + sPortName + '" SIZE="20" VALUE="" MAXLENGTH="4096">', sTblRow); { do not localize } AddElem(Resp, '<INPUT TYPE="TEXT" NAME="' + sAddress + '" SIZE="40" VALUE="" MAXLENGTH="4096">', sTblRow); { do not localize } Resp.Add('</tr>'); { do not localize } Resp.Add('</table>'); { do not localize } Resp.Add('<p>'); { do not localize } Resp.Add('<INPUT TYPE="SUBMIT" VALUE="' + sAddButtonCaption + '" NAME="COMMAND_ADD">'); { do not localize } Resp.Add('<INPUT TYPE="SUBMIT" VALUE="' + sDeleteButtonCaption + '" NAME="COMMAND_REMOVE">'); { do not localize } Resp.Add('</FORM>'); { do not localize } end; procedure GetServicePorts(PortType: string); var I: Integer; IniFile: TMemIniFile; PortList: TStringList; begin IniFile := TMemIniFile.Create(AdminIniFile); try { If the section exists, use what's there} if IniFile.SectionExists(PortType) then begin PortList := TStringList.Create; try IniFile.ReadSectionValues(PortType, PortList); Pub.PortNames := nil; Pub.Locations := nil; SetLength(Pub.PortNames, PortList.Count); SetLength(Pub.Locations, PortList.Count); for I := 0 to PortList.Count - 1 do begin Pub.PortNames[I] := PortList.Names[I]; Pub.Locations[I] := PortList.Values[PortList.Names[I]]; end; finally PortList.Free; end; end else { Here there was nothing for this PortType in the .INI file... So we create at least one default so we have something for the address location } begin Pub.PortNames := nil; Pub.Locations := nil; SetLength(Pub.PortNames, 1); SetLength(Pub.Locations, 1); Pub.PortNames[0] := getDefaultPortKey(PortType); Pub.Locations[0] := getDefaultPortValue(PortType); end; finally IniFile.Free; end; end; var LastName, PreName: string; WSDL: string; WSDLBaseURL: String; begin Result := 200; LastName := Copy(Path, LastDelimiter('/', Path) + 1, High(Integer)); PreName := Copy(Path, 1, LastDelimiter('/', Path) - 1); PreName := Copy(PreName, LastDelimiter('/', PreName) + 1, High(Integer)); WSDLBaseURL := HostScriptBaseURL + Path; {$IFDEF MSWINDOWS} CoInitialize(nil); {$ENDIF} try Pub := TWSDLPublish.Create; try Pub.TargetNamespace := TargetNamespace; Pub.OnBeforePublishingWSDL := FOnBeforePublishingWSDL; Pub.OnBeforePublishingTypes := FOnBeforePublishingTypes; Pub.OnPublishingType := FOnPublishingType; Pub.OnAfterPublishingWSDL := FOnAfterPublishingWSDL; CreateDefaultEntries; if LastName = 'wsdl' then { do not localize } begin Resp.Add(Format(HTMLTopTitleNoMargin, [ServiceName]) + InfoTitle1 + Format(InfoTitle2, [ServiceName, sWebServiceListing])); Resp.Add('<center><br>'); { do not localize } AddInterfaceList(Resp, WSDLBaseURL); if AdminEnabled then AddAdmin(WSDLBaseURL + '/' + 'admin'); { do not localize } Resp.Add('</center>'); { do not localize } Resp.Add(HTMLEnd); ContentType := sTextHtml; end else if LastName = 'admin' then { do not localize } begin if not AdminEnabled then begin Result := 403; Resp.Add(sForbiddenAccess); ContentType := sTextHtml; Exit; end; Resp.Add(Format(HTMLTopTitle, [sWebServiceListingAdmin])); Resp.Add('<h1>' + sWebServiceListingAdmin + '</h1><p>'); { do not localize } AddInterfaceList(Resp, WSDLBaseURL); Resp.Add(HTMLEnd); ContentType := sTextHtml; end else begin if PreName = 'wsdl' then { do not localize } begin GetServicePorts(LastName); WSDL := Pub.GetWSDLForPortType(LastName); if WSDL <> '' then begin Resp.Add(UTF8Encode(WSDL)); ContentType := sTextXML; end else begin { interface not found... } Resp.Add(Format(sInterfaceNotFound, [LastName])); ContentType := sTextHtml; end; end else if PreName = 'admin' then { do not localize } begin if not AdminEnabled then begin Result := 403; Resp.Add(sForbiddenAccess); ContentType := sTextHtml; Exit; end; if Request.QueryFields.Values['COMMAND_ADD'] <> '' then UpdatePortList(Request.QueryFields, LastName, 'ADD') { do not localize } else if Request.QueryFields.Values['COMMAND_REMOVE'] <> '' then UpdatePortList(Request.QueryFields, LastName, 'Remove'); { do not localize } Resp.Add(Format(HTMLTopTitle, [sWSDLPortsforPortType])); Resp.Add('<h1>' + sWSDLPortsforPortType + ' ' + LastName + '</h1><p>'); { do not localize } AddPortList(Resp, LastName); Resp.Add('<p>'); { do not localize } NewServicePortForm; Resp.Add(HTMLEnd); { do not localize } ContentType := sTextHtml; end; end; finally Pub.Free; end; finally {$IFDEF MSWINDOWS} CoUnInitialize; {$ENDIF} end; end; function TWSDLHTMLPublish.DispatchRequest(Sender: TObject; Request: TWebRequest; Response: TWebResponse): Boolean; var Resp: TStringList; Path: string; HostScriptBaseURL: String; ContentType: String; begin try HostScriptBaseURL := GetHostScriptBaseURL(Request); Path := Request.InternalPathInfo; { Strip ending '/' } if Path[Length(Path)] = '/' then Path := Copy(Path, 1, Length(Path)-1); {$IFDEF MSWINDOWS} CoInitialize(nil); {$ENDIF} try Resp := TStringList.Create; try Response.StatusCode := HandleRequest(Resp, Path, HostScriptBaseURL, ContentType, Request); Response.ContentType := ContentType; Response.Content := Resp.Text; finally Resp.Free; end; finally {$IFDEF MSWINDOWS} CoUnInitialize; {$ENDIF} end; except on E: Exception do begin Response.Content := HTMLTop+'<h1>' + sErrorColon + E.Message + '/'+ E.ClassName+'</h1>'+HTMLEnd; { do no localize } Response.ContentType := sTextHtml; end else begin Response.Content := HTMLTop+'<h1>'+sUnknownError +'</h1>'+HTMLEnd; { do not localize } Response.ContentType := sTextHtml; end; end; Result := True; end; procedure TWSDLHTMLPublish.ServiceInfo(Sender: TObject; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); const IntfHdr = '<br><table width="100%" border=0 cellpadding=1 cellspacing=0>' + sLineBreak; IntfSectBig = '<tr><td width="1%" class="Info"> </td><td width="99%" class="Info">' + sLineBreak; IntfSect = '<tr><td width="1%"> </td><td width="99%">' + sLineBreak; IntfSectEnd = '</td></tr>' + sLineBreak + '<tr><td> </td><td> </td></tr>' + sLineBreak; IntfBeg = '<tr>' + '<td width="1%"> </td>' + '<td width="99%">' + '<ul>'; IntfEntL= '<li>' + sLineBreak + '<a class="IntfName" href="%1:s?' + sQueryStringIntf + '=%0:s">%0:s</a>' + sLineBreak; IntfEntP= '<li>' + sLineBreak + '<span class="IntfName">%0:s</span>' + sLineBreak; IntfWSDL= '<span class="WSDL">[</span>' + '<a class="WSDL" href="%s">WSDL</a>' + '<span class="WSDL">]</span>' + sLineBreak; IntfNS = ' <span class="Namespace">(%0:s)</span>' + sLineBreak; IntDoc1= '<table><tr><td width="2%"> </td><td>' + sLineBreak; IntDoc2= '<span class="Tip">%s</span></td></tr></table>' + sLineBreak; MethBeg= '<ul>'; MethEnt= '<li><span class="MethName">%s</span></li>'; MethEnd= '</ul>'; MethBeg2= '<table>' + sLineBreak; MethEnt2= '<tr><td width="10%%" class="MethName"> </td>' + '<td class="ParmName">%s</td><td>%s</td></tr>' + sLineBreak; MethEnt3= '<span class="MethName">%s(</span>%s<span class="MethName">)</span>'; MethEnd2= '</table>' + sLineBreak; IntfEnd= '</li>' + '</ul>' + '</td>' + '</tr>'; IntfFtr= '</table>'; RegHdr = '<a name="types"></a><center><h3>Registered Types</h3>' + '<table cellpadding=2 cellspacing=1 border=0><tr>' + '<td class="TblHdr">Type</td>' + '<td class="TblHdr">XML Name</td>' + '<td class="TblHdr">Namespace</td>' + '<td class="TblHdr">Class</td>' + '<td class="TblHdr">Address</td>' + '<td class="TblHdr">ExtName</td></tr>'; RegRow = '%0:s<tr>' + '<td class="%1:s">%2:s</td>' + '<td class="%1:s">%3:s</td>' + '<td class="%1:s">%4:s</td>' + '<td class="%1:s">%5:s %6:s</td>' + '<td class="%1:s">%7:d</td>' + '<td class="%1:s">%8:s</td></tr>'; RegFtr = '</table></center>'; TTypeKindStrings: array[TTypeKind] of string = ('(tkUnknown)', '(tkInteger)', '(tkChar)', '(tkEnumeration)', '(tkFloat)', '(tkString)', '(tkSet)', '', '(tkMethod)', '(tkWChar)', '(tkLString)', '(tkWString)', '(tkVariant)', '(tkArray)', '(tkRecord)', '(tkInterface)', '(tkInt64)', '(tkDynArray)'); sWSILPath = '/inspection.wsil'; var Path: string; HostScriptBaseURL: String; function ValidIntfName(const Entries: TInvRegIntfEntryArray; const name: string): Boolean; var Entry: InvRegIntfEntry; I: Integer; begin Result := False; if Length(Entries) > 0 then begin for I := 0 to Length(Entries)-1 do begin Entry := Entries[I]; if Entry.Name = name then begin Result := True; Exit; end; end; end; end; function GetReturnStr(const RInfo: PTypeInfo): string; var IsScalar: Boolean; URI, Name: WideString; begin Result := 'void '; { Do not localize } if RInfo <> nil then begin if RemClassRegistry.InfoToURI(RInfo, URI, Name, IsScalar) then Result := Name + ' ' else Name := '????'; { Do not localize } end; end; function GetParams(const Params: TIntfParamEntryArray): string; const Commas : array[Boolean] of string = ('', ', '); var I: Integer; Param: TIntfParamEntry; PName, TName: string; IsScalar: Boolean; URI, Name: WideString; begin Result := ''; if Length(Params) > 0 then begin for I := 0 to Length(Params)-1 do begin Param := Params[I]; if Param.Info = nil then continue; if RemClassRegistry.InfoToURI(Param.Info, URI, Name, IsScalar) then TName := Name else TName := '????'; { Do not localize } PName := Param.Name; Result:= Format('%s' + { Do not localize } '<span class="MethName">%s</span>'+ { Do not localize } '<span class="ParmName">%s</span>'+ { Do not localize } '<span class="MethName"> %s</span>', { Do not localize } [Result, Commas[Length(Result)>0], TName, PName]); end; end; end; function GetInterfaceInfo(const name: string): string; var Entries: TInvRegIntfEntryArray; Entry: InvRegIntfEntry; I, J: Integer; IntfInfo: PTypeInfo; IntfMD: TIntfMetaData; MethEntry: TIntfMethEntry; Namespace: string; IntfName : string; FuncSig, RetStr: string; begin; Result := ''; Pub.GetPortTypeEntries(Entries); { Check if it's for a special interface } if name <> '' then begin if ValidIntfName(Entries, name) then IntfName := name else IntfName := ''; end; if Length(Entries) > 0 then begin Result := IntfHdr; if IntfName = '' then Result := Result + IntfSectBig + Format(sServiceInfo, [ServiceName]) + IntfSectEnd else begin Result := Result + IntfSectBig + Format(sInterfaceInfo, [HostScriptBaseURL, ServiceName, IntfName]) + IntfSectEnd; end; for I := 0 to Length(Entries)-1 do begin Entry := Entries[I]; if (IntfName <> '') and (Entry.Name <> IntfName) then continue; IntfInfo := InvRegistry.GetInterfaceTypeInfo(Entry.GUID); GetIntfMetaData(IntfInfo, IntfMD); Result := Result + IntfBeg; { Display linked or plain version of interface name } if (IntfName <> '') then Result := Result + Format(IntfEntP, [IntfMD.Name]) else Result := Result + Format(IntfEntL, [IntfMD.Name, HostScriptBaseURL]); { Add link to WSDL } Result := Result + Format(IntfWSDL, [HostScriptBaseURL + '/wsdl/'+IntfMD.Name]); if IntfName <> '' then begin Namespace:= InvRegistry.GetNamespaceByGUID(Entry.GUID); Result := Result + Format(IntfNS, [Namespace]); end; if Entry.Documentation <> '' then begin Result := Result + IntDoc1; Result := Result + Format(IntDoc2, [Entry.Documentation]); end; if Length(IntfMD.MDA) > 0 then begin if IntfName <> '' then Result := Result + MethBeg2; for J := 0 to Length(IntfMD.MDA)-1 do begin MethEntry := IntfMD.MDA[J]; if IntfName <> '' then begin FuncSig:= Format(MethEnt3, [IntfMD.MDA[J].Name, GetParams(MethEntry.Params)]); RetStr := GetReturnStr(MethEntry.ResultInfo); Result := Result + Format(MethEnt2, [RetStr, FuncSig]); end else begin Result := Result + MethBeg + Format(MethEnt, [IntfMD.MDA[J].Name]) + MethEnd; end; end; if IntfName <> '' then Result := Result + MethEnd2; end; Result := Result + IntfEnd; end; { WSIL Link } if IntfName = '' then begin Result := Result + IntfSectBig + sWSILInfo + Format(sWSILLink, [HostScriptBaseUrl+sWSILPath]) + IntfSectEnd; end; Result := Result + IntfFtr; end; end; function GetRegisteredTypes: string; var I: Integer; Entry: TRemRegEntry; ObjName: string; InfoName: string; Style: string; begin Result := ''; if RemClassRegistry.GetURICount > 0 then begin Result := RegHdr; for I := 0 to RemClassRegistry.GetURICount-1 do begin RemClassRegistry.GetURIMap(I, Entry); if Assigned(Entry.ClassType) then ObjName := Entry.ClassType.ClassName else ObjName := ''; InfoName := Entry.Info.Name; Style := TblCls[I and 1 = 0]; Result := Format(RegRow, [Result, Style, InfoName, Entry.Name, Entry.URI, ObjName, TTypeKindStrings[Entry.Info.Kind], Integer(Entry.Info), Entry.ExtName]); end; Result := Result + RegFtr; end; end; var RegTypes: string; IntfInfo: string; IntfName: string; begin HostScriptBaseURL := GetHostScriptBaseURL(Request); Path := Request.InternalPathInfo; { WSIL } if SameText(Path, sWSILPath) then begin WSILInfo(HostScriptBaseURL, Request, Response, Handled); Exit; end; try if (Request.QueryFields.Values[sQueryStringTypes] = '1' ) then RegTypes := GetRegisteredTypes; except { Don't let retrieval of bad types bring us down - IOW, since there's no way to enforce registration or registration of valid types, for that matter, let's be safe } end; { See if request was for a special interface } IntfName := Request.QueryFields.Values[sQueryStringIntf]; IntfInfo := GetInterfaceInfo(IntfName); Response.Content := Format(HTMLTopTitleNoMarginWSIL, [ServiceName]) + InfoTitle1 + Format(InfoTitle2, [ServiceName, sServiceInfoPage]) + IntfInfo + RegTypes + HTMLEnd; Handled := True; end; procedure TWSDLHTMLPublish.WSILInfo(const HostScriptBaseURL: string; Request: TWebRequest; Response: TWebResponse; var Handled: Boolean); var Entries: TInvRegIntfEntryArray; Entry: InvRegIntfEntry; I: Integer; Inspection: IXMLInspection; Service: IXMLServiceType; Abstrct: IXMLTypeOfAbstract; Name: IXMLNameType; Description: IXMLDescriptionType; ServiceName: WideString; begin CoInitialize(nil); try Inspection := Newinspection; Pub.GetPortTypeEntries(Entries); if Length(Entries) > 0 then begin for I := 0 to Length(Entries)-1 do begin Entry := Entries[I]; { Service Name } if Entry.ExtName <> '' then ServiceName := Entry.ExtName else ServiceName := Entry.Name; Service := Inspection.Service.Add; { Abstract } Abstrct := Service.Add; Abstrct.Text := Entry.Documentation; { Name } Name := Service.Name.Add; Name.Text := ServiceName; { WSDL Description } Description := Service.Description.Add; Description.ReferencedNamespace := Wsdlns; Description.Location := HostScriptBaseURL + '/wsdl/' + Entry.Name; end; end; Response.Content := Inspection.OwnerDocument.XML.Text; Response.ContentType := sTextXML; Handled := True; finally // ** Ugly fix to workaround CoUnitialize bug // ** This will probably destabilize things somewhere, but this is experimental anyway // CoUninitialize; end; end; function TWSDLHTMLPublish.GetTargetNamespace: WideString; begin if (FTargetNamespace <> '') then Result := FTargetNamespace else Result := WSDLIntf.tns; end; procedure TWSDLHTMLPublish.SetWebDispatch(const Value: TWebDispatch); begin FWebDispatch.Assign(Value); end; initialization { IWSDLPublish registration } InvRegistry.RegisterInterface(TypeInfo(IWSDLPublish), SBorlandTypeNamespace, '', IWSDLPublishDoc); InvRegistry.RegisterDefaultSOAPAction(TypeInfo(IWSDLPublish), SBorlandTypeNamespace + '-IWSDLPublish'); InvRegistry.RegisterInvokableClass(TWSDLPublish); { Admin Ini File } GetModuleFileName(HInstance, ModuleName, SizeOf(ModuleName)); ServicePath := Copy(ModuleName, 1, StrLen(ModuleName) - Cardinal(Length(ExtractFileExt(ModuleName)))); ServiceName := 'Grendel WebService'; //ExtractFileName(ServicePath); AdminIniFile:= ServicePath + '_WSDLADMIN.INI'; { do not localize } end.