使用http.sys，让delphi 的多层服务真的飞起来

Posted 2020-11-07 c5soft

原delphi窑洞洞主xalion在自己的博客上发过一篇文章：
《使用http.sys，让delphi 的多层服务飞起来》
http://www.cnblogs.com/xalion/p/6219515.html
这里边提到如何把mormot的httpserver抠出来，嫁接到webbroker上，非常好的思路。
可惜xalion没贴出全部源代码。

最近对WebBroker做了点深入研究，给出了c5soft的实现，贴出全部源代码。
目前是0.0.0.1版本，仅搭了个框架，但是明眼人一看就明白实现思路，一步一步可以把整个框架填满。
源代码在Delphi7 与Delphi 10.2下编译通过。

原代码在这里下载：https://wedelphi.com/t/419364/

框架的核心是 SynWebApp.pas，随后贴出。先看看SynBrokerTest.dpr

···
program SynBrokerTest;

{$APPTYPE CONSOLE}

uses
{$IFNDEF UNICODE}
FastMM4,
{$ENDIF}
WebBroker,
SynWebApp in ‘SynWebApp.pas‘,
uWebModule in ‘uWebModule.pas‘ {WebModule1: TWebModule};

{$R *.res}

begin
{$IFDEF UNICDOE}
ReportMemoryLeaksOnShutDown := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TWebModule1, WebModule1);
Application.Run;
end.
···

下面是框架的核心文件SynWebApp.pas
···
{ *************************************************************************** }
{ mORMot HttpServer WebBroker Bridge }
{ by [email protected] Version 0.0.0.1 2018-5-20 }
{ *************************************************************************** }

{$DENYPACKAGEUNIT}

unit SynWebApp;

interface

uses Classes, SysUtils, WebBroker, HTTPApp, SynCommons, SynCrtSock;

const
//Request Header String
cstInHeaderMethod = 0; //string
cstInHeaderProtocolVersion = 1; //string
cstInHeaderURL = 2; //string
cstInHeaderQuery = 3; //string
cstInHeaderPathInfo = 4; //string
cstInHeaderPathTranslated = 5; //string
cstInHeaderCacheControl = 6; //string
cstInHeaderAccept = 8; //string
cstInHeaderFrom = 9; //string
cstInHeaderHost = 10; //string
cstInHeaderReferer = 12; //string
cstInHeaderUserAgent = 13; //string
cstInHeaderContentEncoding = 14; //string
cstInHeaderContentType = 15; //string
cstInHeaderContentVersion = 17; //string
cstInHeaderDerivedFrom = 18; //string
cstInHeaderTitle = 20; //string
cstInHeaderRemoteAddr = 21; //string
cstInHeaderRemoteHost = 22; //string
cstInHeaderScriptName = 23; //string
cstInHeaderContent = 25; //string
cstInHeaderConnection = 26; //string
cstInHeaderCookie = 27; //string
cstInHeaderAuthorization = 28; //string
//Request Header Integer
cstInHeaderContentLength = 16; //Integer
cstInHeaderServerPort = 24; //Integer
//Request Header DateTime
cstInHeaderDate = 7; //TDateTime
cstInHeaderIfModifiedSince = 11; //TDateTime
cstInHeaderExpires = 19; //TDateTime

//Response Header String
cstOutHeaderVersion = 0; //string
cstOutHeaderReasonString = 1; //string
cstOutHeaderServer = 2; //string
cstOutHeaderWWWAuthenticate = 3; //string
cstOutHeaderRealm = 4; //string
cstOutHeaderAllow = 5; //string
cstOutHeaderLocation = 6; //string
cstOutHeaderContentEncoding = 7; //string
cstOutHeaderContentType = 8; //string
cstOutHeaderContentVersion = 9; //string
cstOutHeaderDerivedFrom = 10; //string
cstOutHeaderTitle = 11; //string
//Response Header Integer
cstOutHeaderContentLength = 0; //Integer
//Response Header DateTime
cstOutHeaderDate = 0; //TDateTime
cstOutHeaderExpires = 1; //TDateTime
cstOutHeaderLastModified = 2; //TDateTime

type

TSynWebReqest = class(TWebRequest)
private
function GetHeader(const AUpKey: RawUTF8; const ASource: RawUTF8 = ‘‘; const Sep: AnsiChar = #13): RawUTF8;
protected
FContext: THttpServerRequest;
function GetStringVariable(Index: Integer): string; override;
function GetDateVariable(Index: Integer): TDateTime; override;
function GetIntegerVariable(Index: Integer): Integer; override;
function GetInternalPathInfo: string; override;
function GetInternalScriptName: string; override;
public
constructor Create(const AContext: THttpServerRequest);
// Read count bytes from client
function ReadClient(var Buffer; Count: Integer): Integer; override;
// Read count characters as a string from client
function ReadString(Count: Integer): string; override;
// Translate a relative URI to a local absolute path
function TranslateURI(const URI: string): string; override;
// Write count bytes back to client
function WriteClient(var Buffer; Count: Integer): Integer; override;
// Write string contents back to client
function WriteString(const AString: string): Boolean; override;
// Write HTTP header string
function WriteHeaders(StatusCode: Integer; const ReasonString, Headers: string): Boolean; override;
function GetFieldByName(const Name: string): string; override;
property Context: THttpServerRequest read FContext;
end;

TSynWebResponse = class(TWebResponse)
private
FStatusCode: Integer;
function GetContext: THttpServerRequest;
protected
function GetStringVariable(Index: Integer): string; override;
procedure SetStringVariable(Index: Integer; const Value: string); override;
function GetDateVariable(Index: Integer): TDateTime; override;
procedure SetDateVariable(Index: Integer; const Value: TDateTime); override;
function GetIntegerVariable(Index: Integer): Integer; override;
procedure SetIntegerVariable(Index: Integer; Value: Integer); override;
function GetContent: string; override;
procedure SetContent(const Value: string); override;
procedure SetContentStream(Value: TStream); override;
function GetStatusCode: Integer; override;
procedure SetStatusCode(Value: Integer); override;
function GetLogMessage: string; override;
procedure SetLogMessage(const Value: string); override;
public
procedure SendResponse; override;
procedure SendRedirect(const URI: string); override;
procedure SendStream(AStream: TStream); override;
property Context: THttpServerRequest read GetContext;
end;

TSynWebApplication = class(TWebApplication)
private
fRoot, fPort: SockString;
fServer: THttpApiServer;
function Process(FContext: THttpServerRequest): cardinal;
public
property Port: SockString read fPort;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Run; override;
end;

implementation

uses Windows, BrkrConst, IniFiles, SynZip;

{ TSynWebApplication }

constructor TSynWebApplication.Create;
begin
inherited;
fRoot := ‘‘;
fPort := ‘8080‘;
fServer := THttpApiServer.Create(false);
fServer.AddUrl(fRoot, fPort, false, ‘+‘, true);
fServer.RegisterCompress(CompressDeflate); // our server will deflate html :)
fServer.OnRequest := Process;
fServer.Clone(31); // will use a thread pool of 32 threads in total
end;

destructor TSynWebApplication.Destroy;
begin
fServer.RemoveUrl(fRoot, fPort, False, ‘+‘);
fServer.Free;
inherited;
end;

procedure WaitForEscKey;
var
LInputRecord: TInputRecord;
LEvent: DWord;
LHandle: THandle;
begin
LHandle := GetStdHandle(STD_INPUT_HANDLE);
while True do begin
Win32Check(ReadConsoleInput(LHandle, LInputRecord, 1, LEvent));
if (LInputRecord.EventType = KEY_EVENT) and
LInputRecord.Event.KeyEvent.bKeyDown and
(LInputRecord.Event.KeyEvent.wVirtualKeyCode = VK_ESCAPE) then
break;
end;
end;

procedure TSynWebApplication.Run;
begin
WriteLn(‘Server Listening on http://localhost:‘+Port+‘ ...‘);
WriteLn(‘Press ESC to quit‘);
WaitForEscKey;
end;

function TSynWebApplication.Process(FContext: THttpServerRequest): cardinal;
var
HTTPRequest: TSynWebReqest;
HTTPResponse: TSynWebResponse;
begin
Result := 200;
try
HTTPRequest := TSynWebReqest.Create(FContext);
try
HTTPResponse := TSynWebResponse.Create(HTTPRequest);
HTTPResponse.StatusCode := 200;
try
HandleRequest(HTTPRequest, HTTPResponse);
Result := HTTPResponse.StatusCode;
finally
HTTPResponse.Free;
end;
finally
HTTPRequest.Free;
end;
except
//HandleServerException(ExceptObject, Output);
end;
end;

procedure InitApplication;
begin
Application := TSynWebApplication.Create(nil);
end;

{ TSynWebReqest }

function TSynWebReqest.GetHeader(const AUpKey: RawUTF8; const ASource: RawUTF8 = ‘‘; const Sep: AnsiChar = #13):
RawUTF8;
var
P, pUpKey, pSource: PUTF8Char;
cVal: RawUTF8;
begin
pUpKey := PUTF8Char(AUpKey);
if ASource = ‘‘ then
pSource := PUTF8Char(FContext.InHeaders)
else
pSource := PUTF8Char(ASource);
P := StrPosI(pUpKey, pSource);
if IdemPCharAndGetNextItem(P, pUpKey, cVal, Sep) then
Result := Trim(cVal)
else
Result := ‘‘;
end;

constructor TSynWebReqest.Create(const AContext: THttpServerRequest);
begin
FContext := AContext;
end;

function TSynWebReqest.GetDateVariable(Index: Integer): TDateTime;
begin
Result := Now;
end;

function TSynWebReqest.GetFieldByName(const Name: string): string;
begin
Result := ‘‘;
end;

function TSynWebReqest.GetIntegerVariable(Index: Integer): Integer;
begin
if Index = cstInHeaderContentLength then
Result := StrToIntDef(UTF8ToString(GetHeader(‘CONTENT-LENGTH‘)), 0)
else if Index = cstInHeaderServerPort then
Result := 80
else
Result := 0;
end;

function TSynWebReqest.GetInternalPathInfo: string;
begin
Result := ‘‘;
end;

function TSynWebReqest.GetInternalScriptName: string;
begin
Result := ‘‘;
end;

function TSynWebReqest.GetStringVariable(Index: Integer): string;
begin
if Index = cstInHeaderMethod then begin
Result := UTF8ToString(Context.Method);
end else if Index = cstInHeaderProtocolVersion then begin
Result := ‘‘;
end else if Index = cstInHeaderURL then begin
Result := UTF8ToString(Context.URL);
end else if Index = cstInHeaderQuery then begin
Result := ‘‘;
end else if Index = cstInHeaderPathInfo then begin
Result := ‘‘;
end else if Index = cstInHeaderPathTranslated then begin
Result := ‘‘;
end else if Index = cstInHeaderCacheControl then begin
Result := ‘‘;
end else if Index = cstInHeaderAccept then begin
Result := UTF8ToString(GetHeader(‘ACCEPT:‘));
end else if Index = cstInHeaderFrom then begin
Result := UTF8ToString(GetHeader(‘FROM:‘));
end else if Index = cstInHeaderHost then begin
Result := UTF8ToString(GetHeader(‘HOST:‘));
end else if Index = cstInHeaderReferer then begin
Result := UTF8ToString(GetHeader(‘REFERER:‘));
end else if Index = cstInHeaderUserAgent then begin
Result := UTF8ToString(GetHeader(‘USER-AGENT:‘));
end else if Index = cstInHeaderContentEncoding then begin
Result := UTF8ToString(GetHeader(‘CONTENT-ENCODING:‘));
end else if Index = cstInHeaderContentType then begin
Result := UTF8ToString(GetHeader(‘CONTENT-TYPE:‘));
end else if Index = cstInHeaderContentVersion then begin
Result := ‘‘;
end else if Index = cstInHeaderDerivedFrom then begin
Result := ‘‘;
end else if Index = cstInHeaderTitle then begin
Result := ‘‘;
end else if Index = cstInHeaderRemoteAddr then begin
Result := UTF8ToString(GetHeader(‘REMOTEIP:‘));
end else if Index = cstInHeaderRemoteHost then begin
Result := ‘‘;
end else if Index = cstInHeaderScriptName then begin
Result := ‘‘;
end else if Index = cstInHeaderContent then begin
Result := ‘‘;
end else if Index = cstInHeaderConnection then begin
Result := UTF8ToString(GetHeader(‘CONNECTION:‘));
end else if Index = cstInHeaderCookie then begin
Result := UTF8ToString(GetHeader(‘COOKIE:‘));
end else if Index = cstInHeaderAuthorization then begin
Result := ‘‘;
end;
end;

function TSynWebReqest.ReadClient(var Buffer; Count: Integer): Integer;
begin
Result := 0;
end;

function TSynWebReqest.ReadString(Count: Integer): string;
begin
Result := ‘‘;
end;

function TSynWebReqest.TranslateURI(const URI: string): string;
begin
Result := ‘‘;
end;

function TSynWebReqest.WriteClient(var Buffer; Count: Integer): Integer;
begin
Result := 0;
end;

function TSynWebReqest.WriteHeaders(StatusCode: Integer;
const ReasonString, Headers: string): Boolean;
begin
Result := False;
end;

function TSynWebReqest.WriteString(const AString: string): Boolean;
begin
Result := False;
end;

{ TSynWebResponse }

function TSynWebResponse.GetContent: string;
begin
Result := Context.InContent;
end;

function TSynWebResponse.GetContext: THttpServerRequest;
begin
Result := TSynWebReqest(FHTTPRequest).FContext;
end;

function TSynWebResponse.GetDateVariable(Index: Integer): TDateTime;
begin
Result := Now;
end;

function TSynWebResponse.GetIntegerVariable(Index: Integer): Integer;
begin
Result := 0;
end;

function TSynWebResponse.GetLogMessage: string;
begin
Result := ‘‘;
end;

function TSynWebResponse.GetStatusCode: Integer;
begin
Result := FStatusCode;
end;

function TSynWebResponse.GetStringVariable(Index: Integer): string;
begin
Result := ‘‘;
if Index = cstOutHeaderContentType then
Result := Utf8ToString(Context.OutContentType);
end;

procedure TSynWebResponse.SendRedirect(const URI: string);
begin

end;

procedure TSynWebResponse.SendResponse;
begin

end;

procedure TSynWebResponse.SendStream(AStream: TStream);
begin

end;

procedure TSynWebResponse.SetContent(const Value: string);
begin
Context.OutContent := StringToUTF8(Value);
end;

procedure TSynWebResponse.SetContentStream(Value: TStream);
begin

end;

procedure TSynWebResponse.SetDateVariable(Index: Integer;
const Value: TDateTime);
begin

end;

procedure TSynWebResponse.SetIntegerVariable(Index, Value: Integer);
begin

end;

procedure TSynWebResponse.SetLogMessage(const Value: string);
begin

end;

procedure TSynWebResponse.SetStatusCode(Value: Integer);
begin
FStatusCode := Value;
end;

procedure TSynWebResponse.SetStringVariable(Index: Integer;
const Value: string);
begin
if Index = cstOutHeaderContentType then
Context.OutContentType := StringToUTF8(Value);
end;

initialization
InitApplication;
end.
···