Using HTTP. sys, let Delphi's multi-tier services really fly.

Source: Internet
Author: User
Tags webbroker

Original Delphi Cave Cave main Xalion on his blog posted an article:
"Using HTTP. Sys to let Delphi's multi-layered service fly up"
Http://www.cnblogs.com/xalion/p/6219515.html
Here the side mentioned how to Mormot httpserver out, grafting to webbroker, very good ideas.
Unfortunately Xalion did not post all the source code.

Recently did some in-depth research to webbroker, gave the realization of C5soft, put out all source code.
Currently 0.0.0.1 version, only a frame, but discerning eye a look at the realization of ideas, step by step can fill the entire framework.
The source code was compiled by Delphi7 and Delphi 10.2.

The original code is downloaded here: https://wedelphi.com/t/419364/

The core of the framework is Synwebapp.pas, which is then posted. First look at 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.
···

Here is the framework's core file 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 would deflate HTML:)
Fserver.onrequest: = Process;
Fserver.clone (31); Would use a thread pool of threads
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 does 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.
···

Using HTTP. sys, let Delphi's multi-tier services really fly.

Contact Us

The content source of this page is from Internet, which doesn't represent Alibaba Cloud's opinion; products and services mentioned on that page don't have any relationship with Alibaba Cloud. If the content of the page makes you feel confusing, please write us an email, we will handle the problem within 5 days after receiving your email.

If you find any instances of plagiarism from the community, please send an email to: info-contact@alibabacloud.com and provide relevant evidence. A staff member will contact you within 5 working days.

A Free Trial That Lets You Build Big!

Start building with 50+ products and up to 12 months usage for Elastic Compute Service

  • Sales Support

    1 on 1 presale consultation

  • After-Sales Support

    24/7 Technical Support 6 Free Tickets per Quarter Faster Response

  • Alibaba Cloud offers highly flexible support services tailored to meet your exact needs.