paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-19 02:49:18 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Add .ini config file possibility, plus simple proxy server config

Browse Source 
git-svn-id: trunk@42985 -
This commit is contained in:
michael 2019-09-13 16:29:38 +00:00
parent da47ba14c1
commit 31f0bfeb96
1 changed files with 181 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

204
packages/fcl-web/examples/simpleserver/simpleserver.pas
View File

@ -4,13 +4,16 @@
program simpleserver;
uses
sysutils,
sysutils,Classes,
{$ifdef USEGNUTLS}
gnutlssockets,
{$else}
opensslsockets,
{$endif}
sslbase,custhttpapp, fpmimetypes, fpwebfile;
{$ifdef unix}
baseunix,
{$endif}
inifiles, sslbase,httpdefs, custhttpapp, fpmimetypes, fpwebfile, fpwebproxy;
Type
@ -18,13 +21,27 @@ Type
THTTPApplication = Class(TCustomHTTPApplication)
private
FBaseDir: string;
FIndexPageName: String;
FMimeFile: String;
FNoIndexPage: Boolean;
FQuiet: Boolean;
FBackground : Boolean;
procedure AddProxy(const aProxyDef: String);
procedure DoProxyLog(Sender: TObject; const aMethod, aLocation, aFromURL, aToURL: String);
procedure LoadMimeTypes;
procedure ProcessOptions;
procedure ReadConfigFile(const ConfigFile: string);
procedure Usage(Msg: String);
procedure Writeinfo;
published
procedure DoLog(EventType: TEventType; const Msg: String); override;
Procedure DoRun; override;
property Quiet : Boolean read FQuiet Write FQuiet;
Property MimeFile : String Read FMimeFile Write FMimeFile;
Property BaseDir : string Read FBaseDir Write FBaseDir;
Property NoIndexPage : Boolean Read FNoIndexPage Write FNoIndexPage;
Property IndexPageName : String Read FIndexPageName Write FIndexPageName;
end;
Var
@ -42,6 +59,21 @@ begin
inherited DoLog(EventType, Msg);
end;
procedure THTTPApplication.DoProxyLog(Sender: TObject; const aMethod, aLocation, aFromURL, aToURL: String);
Var
Msg : String;
begin
if Quiet then
exit;
Msg:=Format('(Proxy redirect) location: %s, Method: %s, From: %s, to: %s',[aLocation,aMethod,aFromURl,atoURL]);
if IsConsole then
Writeln(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',Now),' [',etInfo,'] ',Msg)
else
inherited DoLog(etInfo, Msg);
end;
procedure THTTPApplication.Usage(Msg : String);
begin
@ -49,6 +81,10 @@ begin
Writeln('Error: ',Msg);
Writeln('Usage ',ExtractFileName(ParamStr(0)),' [options] ');
Writeln('Where options is one or more of : ');
Writeln('-c --config=file Ini configuration file (default: simpleserver.ini)');
{$ifdef unix}
Writeln('-b --background fork to background');
{$endif}
Writeln('-d --directory=dir Base directory from which to serve files.');
Writeln(' Default is current working directory: ',GetCurrentDir);
Writeln('-h --help This help text');
@ -59,6 +95,11 @@ begin
Writeln('-q --quiet Do not write diagnostic messages');
Writeln('-s --ssl Use SSL');
Writeln('-H --hostname=NAME set hostname for self-signed SSL certificate');
Writeln('-x --proxy=proxydef Add proxy definition. Definition is of form:');
Writeln(' name:BaseURL');
Writeln('');
Writeln('Config file is ini file, section [Server]. Key names are long option names');
Writeln('Proxies are defined in section [Proxy], Key is name, value is URL');
Halt(Ord(Msg<>''));
end;
@ -66,9 +107,9 @@ procedure THTTPApplication.LoadMimeTypes;
begin
MimeTypes.LoadKnownTypes;
if HasOption('m','mimetypes') then
if MimeFile<>'' then
begin
MimeTypesFile:=GetOptionValue('m','mimetypes');
MimeTypesFile:=MimeFile;
if (MimeTypesFile<>'') and not FileExists(MimeTypesFile) then
begin
Log(etWarning,'mimetypes file not found: '+MimeTypesFile);
@ -79,40 +120,157 @@ begin
MimeTypes.LoadFromFile(MimeTypesFile);
end;
procedure THTTPApplication.DoRun;
procedure THTTPApplication.AddProxy(Const aProxyDef : String);
Var
S,IndexPage,D : String;
P : Integer;
N,URL : String;
begin
S:=Checkoptions('hqd:ni:p:sH:m:',['help','quiet','noindexpage','directory:','port:','indexpage:','ssl','hostname:','mimetypes:']);
if (S<>'') or HasOption('h','help') then
usage(S);
P:=Pos(':',aProxyDef);
If P=0 then Raise
EHTTP.CreateFmt('Invalid proxy definition: %s',[aProxyDef]);
N:=Copy(aProxyDef,1,P-1);
URL:=Copy(aProxyDef,P+1,Length(aProxyDef));
ProxyManager.RegisterLocation(N,URL);
end;
procedure THTTPApplication.ReadConfigFile(Const ConfigFile : string);
Const
SConfig = 'Server';
SProxy = 'Proxy';
KeyPort = 'Port';
KeyDir = 'Directory';
KeyIndexPage = 'IndexPage';
KeyHostName = 'hostname';
keyMimetypes = 'mimetypes';
KeySSL = 'SSL';
KeyQuiet = 'quiet';
KeyNoIndexPage = 'noindexpage';
KeyBackground = 'background';
Var
L : TStringList;
P,U : String;
I : Integer;
begin
if (ConfigFile='') or Not FileExists(ConfigFile) then exit;
L:=Nil;
With TMemIniFile.Create(ConfigFile) do
try
BaseDir:=ReadString(SConfig,KeyDir,BaseDir);
Port:=ReadInteger(SConfig,KeyPort,Port);
Quiet:=ReadBool(SConfig,KeyQuiet,Quiet);
MimeFile:=ReadString(SConfig,keyMimetypes,MimeFile);
NoIndexPage:=ReadBool(SConfig,KeyNoIndexPage,NoIndexPage);
IndexPageName:=ReadString(SConfig,KeyIndexPage,IndexPageName);
HostName:=ReadString(SConfig,KeyHostName,HostName);
UseSSL:=ReadBool(SConfig,KeySSL,UseSSL);
FBackground:=ReadBool(SConfig,Keybackground,FBackGround);
L:=TstringList.Create;
ReadSectionValues(SProxy,L,[]);
For I:=0 to L.Count-1 do
begin
L.GetNameValue(I,P,U);
if (P<>'') and (U<>'') then
ProxyManager.RegisterLocation(P,U);
end;
finally
L.Free;
Free;
end;
end;
procedure THTTPApplication.ProcessOptions;
Var
S : String;
begin
for S in GetOptionValues('x','proxy') do
AddProxy(S);
Quiet:=HasOption('q','quiet');
Port:=StrToIntDef(GetOptionValue('p','port'),3000);
Port:=StrToIntDef(GetOptionValue('p','port'),Port);
LoadMimeTypes;
D:=GetOptionValue('d','directory');
if D='' then
D:=GetCurrentDir;
Log(etInfo,'Listening on port %d, serving files from directory: %s',[Port,D]);
if HasOption('d','directory') then
BaseDir:=GetOptionValue('d','directory');
UseSSL:=HasOption('s','ssl');
if HasOption('H','hostname') then
HostName:=GetOptionValue('H','hostname');
TSimpleFileModule.BaseDir:=IncludeTrailingPathDelimiter(D);
TSimpleFileModule.OnLog:=@Log;
If not HasOption('n','noindexpage') then
if HasOption('n','noindexpage') then
NoIndexPage:=True
else
IndexPageName:=GetOptionValue('i','indexpage');
FBackground:=HasOption('b','background');
end;
procedure THTTPApplication.Writeinfo;
Var
I : Integer;
begin
Log(etInfo,'Listening on port %d, serving files from directory: %s (using SSL: %s)',[Port,BaseDir,BoolToStr(UseSSL,'true','false')]);
For I:=0 to ProxyManager.LocationCount-1 do
with ProxyManager.Locations[i] do
Log(etInfo,'Proxy location /proxy/%s redirects to %s',[Path,URL]);
if not NoIndexPage then
Log(etInfo,'Using index page %s',[IndexPageName]);
end;
procedure THTTPApplication.DoRun;
Var
S,ConfigFile : String;
begin
S:=Checkoptions('hqd:ni:p:sH:m:x:c:b',['help','quiet','noindexpage','directory:','port:','indexpage:','ssl','hostname:','mimetypes:','proxy:','config:','background']);
if (S<>'') or HasOption('h','help') then
usage(S);
if HasOption('c','config') then
ConfigFile:=GetOptionValue('c','config')
else
ConfigFile:='simpleserver.ini';
ReadConfigFile(ConfigFile);
ProcessOptions;
if FBackground then
begin
IndexPage:=GetOptionValue('i','indexpage');
if IndexPage='' then
IndexPage:='index.html';
Log(etInfo,'Using index page %s',[IndexPage]);
TSimpleFileModule.IndexPageName:=IndexPage;
{$ifdef unix}
if FPFork>0 then Halt(0);
{$else}
Log(erError,'Background option not supported');
{$endif}
end;
if ProxyManager.LocationCount>0 then
begin
TProxyWebModule.RegisterModule('Proxy',True);
ProxyManager.OnLog:=@DoProxyLog;
end;
if BaseDir='' then
BaseDir:=GetCurrentDir;
if (BaseDir<>'') then
BaseDir:=IncludeTrailingPathDelimiter(BaseDir);
TSimpleFileModule.RegisterDefaultRoute;
TSimpleFileModule.BaseDir:=BaseDir;
TSimpleFileModule.OnLog:=@Log;
If not NoIndexPage then
begin
if (IndexPageName='') then
IndexPageName:='index.html';
TSimpleFileModule.IndexPageName:=IndexPageName;
end;
if not Quiet then
WriteInfo;
inherited;
end;
begin
TSimpleFileModule.RegisterDefaultRoute;
Application:=THTTPApplication.Create(Nil);
Application.Initialize;
Application.Run;