Ciao SB.Https, ti serve veramente?Altrimenti una cosina del tipo :) ?
interface
uses
Classes, SysUtils, custhttpapp, fphttpapp, httproute, HTTPDefs, fpjson, fpjsonrtti, om;
type
{ TFakeJsonServer }
TFakeJsonServer = class(TCustomHTTPApplication)
public
procedure Initialize; override;
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
function getMethod(aMethodString: string): TRouteMethod;
protected
procedure Process1(ARequest: TRequest; AResponse: TResponse);
procedure Response404(ARequest: TRequest; AResponse: TResponse);
end;
var
Application: TFakeJsonServer;
ShowCleanUpErrors: boolean = False;
implementation
uses
CustApp, jsonparser;
{ TFakeJsonServer }
constructor TFakeJsonServer.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
end;
destructor TFakeJsonServer.Destroy;
begin
inherited Destroy;
end;
function TFakeJsonServer.getMethod(aMethodString: string): TRouteMethod;
begin
aMethodString := upperCase(aMethodString);
if aMethodString = 'GET' then
exit(rmGet)
else if aMethodString = 'POST' then
exit(rmPost)
else if aMethodString = 'PUT' then
exit(rmPut)
else if aMethodString = 'OPTIONS' then
exit(rmOptions)
else if aMethodString = 'HEAD' then
exit(rmHead)
else if aMethodString = 'TRACE' then
exit(rmTrace)
else
exit(rmAll);
end;
procedure TFakeJsonServer.Process1(ARequest: TRequest; AResponse: TResponse);
var
Parameters: TStringList;
r: THTTPRoute;
index: integer;
aName, aValue: string;
begin
Parameters := TStringList.Create;
try
r := httprouter.GetHTTPRoute(ARequest.URL, getMethod(ARequest.Method), Parameters);
if r <> nil then
begin
for index := 0 to Parameters.Count - 1 do
begin
Parameters.GetNameValue(index, aName, aValue);
Writeln(index, ':', aName, '->', aValue);
end;
end;
except
on e: Exception do
begin
Writeln(e.Message);
end;
end;
FreeAndNil(Parameters);
end;
procedure TFakeJsonServer.Response404(ARequest: TRequest; AResponse: TResponse);
begin
AResponse.Content := '{ status :400 }';
end;
procedure TFakeJsonServer.Initialize;
begin
inherited Initialize;
RedirectOnError := True; Application.Threaded := True;
Application.Port := 0000; // quella che vuoi
HTTPRouter.RegisterRoute('url1',getMethod('get'), @Process1);
HTTPRouter.RegisterRoute('url2',getMethod('delete'), @Process2);
HTTPRouter.RegisterRoute('url3',getMethod('post'), @Process3);
end;
procedure InitHTTP;
begin
Application := TFakeJsonServer.Create(nil);
if not assigned(CustomApplication) then
CustomApplication := Application;
end;
procedure DoneHTTP;
begin
if CustomApplication = Application then
CustomApplication := nil;
try
FreeAndNil(Application);
except
if ShowCleanUpErrors then
raise;
end;
end;
initialization
InitHTTP;
finalization
DoneHTTP;
end.
ah e :begin
Application.Title := 'FakeJSonServer';
Application.Initialize;
Application.StopOnException := False;
WriteLn('Accept request on port :', Application.Port);
Application.Run;
Application.Free;
end.
Da https://github.com/paxtibi/jsonserver/blob/master/src/app.pas (https://github.com/paxtibi/jsonserver/blob/master/src/app.pas)
procedure TFakeJsonServer.Initialize;
var
FileStream: TFileStream;
DeStreamer: TJSONDeStreamer;
c: TCollectionItem;
r: TRouterObject;
jsonData: TJSONStringType;
handle: TRouter;
begin
inherited Initialize;
Application.Threaded := True;
RedirectOnError := True;
FileStream := TFileStream.Create('config.json', fmOpenRead);
SetLength(jsonData, FileStream.Size);
FileStream.Read(jsonData[1], FileStream.Size);
Writeln(jsonData);
DeStreamer := TJSONDeStreamer.Create(nil);
try...
ah vedo che eredita da TCustomHTTPApplication
TFakeJsonServer = class(TCustomHTTPApplication)
allora il multithreading dovrebbe essere affidabile :)