Delphi/FastReport_2022_VCL
Delphi/FastReport_2022_VCL
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
master
FastReport_2022_VCL/LibD28/frxServer.pas
Daso e6303fc1c0 Inicijalizacija
2024-01-01 16:13:08 +01:00

2627 lines
80 KiB
ObjectPascal
Raw Permalink Blame History

{******************************************}
{ }
{ FastReport VCL }
{ HTTP Report Server }
{ }
{ Copyright (c) 1998-2021 }
{ by Fast Reports Inc. }
{ }
{******************************************}
unit frxServer;
{$I frx.inc}
{$IFDEF Delphi12}
{$WARNINGS OFF}
{$ENDIF}
//{$DEFINE DEBUG}
//{$DEFINE CS_ON}
interface
uses
Forms,
{$IFDEF FPC}
{$IFDEF Linux}
BaseUnix, Unix, LCLType, LCLIntf, Types, LResources, LMessages, LazHelperCS,
{$ELSE}
Windows, WinSock,
{$ENDIF}
LazHelper, LazSocket,
{$ELSE}
Windows, WinSock, ScktComp, frxThreading,
{$ENDIF}
Classes, frxClass, Registry, frxVariables, frxGZip, frxServerLog,
frxServerSessionManager, frxServerStat, frxServerReports,
frxServerVariables, frxServerSSI, frxServerUtils, frxNetUtils, frxMD5,
frxServerCache, frxServerReportsList, frxUnicodeUtils, frxUsers, frxHelperCS
// , frxADOComponents,
// DB, ADODB
{$IFDEF FR_FIB}
, frxFIBComponents, FIBDatabase, pFIBDatabase
{$ENDIF}
, frxServerClient, SysUtils, frxServerConfig, frxServerTemplates, frxServerPrinter;
type
TfrxHTTPServer = class;
TfrxServerSession = class;
TfrxServerData = class;
TfrxServerGuard = class;
TfrxServerGetReportEvent = procedure(const ReportName: String;
Report: TfrxReport; User: String = '') of object;
TfrxServerGetVariablesEvent = procedure(const ReportName: String;
Variables: TfrxVariables; User: String = '') of object;
TfrxServerAfterBuildReport = procedure(const ReportName: String;
Variables: TfrxVariables; User: String = '') of object;
PSecHandle = ^TSecHandle;
TSecHandle = record
dwLower: Cardinal;
dwUpper: Cardinal;
end;
TCredHandle = TSecHandle;
PCredHandle = ^TCredHandle;
PCtxtHandle = ^TCtxtHandle;
TCtxtHandle = TSecHandle;
PSecBuffer = ^TSecBuffer;
TSecBuffer = record
cbBuffer: Cardinal;
BufferType: Cardinal;
pvBuffer: Pointer;
end;
PSecBufferDesc = ^TSecBufferDesc;
TSecBufferDesc = record
ulVersion: Cardinal;
cBuffers: Cardinal;
pBuffers: PSecBuffer;
end;
PTimeStamp = ^TTimeStamp;
TTimeStamp = Currency;
PSecPkgInfo = ^TSecPkgInfo;
TSecPkgInfo = record
fCapabilities: Cardinal;
wVersion: Word;
wRPCID: Word;
cbMaxToken: Cardinal;
Name: PChar;
Comment: PChar;
end;
{$IFDEF DELPHI16}
[ComponentPlatformsAttribute(pidWin32 or pidWin64)]
{$ENDIF}
TfrxReportServer = class(TComponent)
private
FActive: Boolean;
FAllow: TStrings;
FDeny: TStrings;
FGetReport: TfrxServerGetReportEvent;
FPDFPrint: Boolean;
FTotals: TStrings;
FConfigLoaded: Boolean;
FVariables: TfrxServerVariables;
FWebServer: TfrxHTTPServer;
FGetVariables: TfrxServerGetVariablesEvent;
FBuildReport: TfrxServerAfterBuildReport;
FBusy: Boolean;
// FADOComponents: TfrxADOComponents;
// FADOConnection: TADOConnection;
{$IFDEF FR_FIB}
FFIBComponents: TfrxFIBComponents;
FfrxFIBConnection: TfrxFIBDatabase;
{$ENDIF}
FSocketOpen: Boolean;
FConfigFileName: String;
FGuard: TfrxServerGuard;
FPrint: Boolean;
function GetTotals: TStrings;
procedure SetActive(const Value: Boolean);
procedure StatToVar;
// procedure IdleEventHandler(Sender: TObject; var Done: Boolean);
procedure Initialize;
public
constructor Create(AOwner: TComponent); override;
constructor CreateWithRoot(const Folder: String; const Socket: Boolean);
destructor Destroy; override;
procedure Open;
procedure Close;
procedure Get(Data: TfrxServerData);
function LoadConfigs: Boolean;
property Totals: TStrings read GetTotals;
property Variables: TfrxServerVariables read FVariables;
property WebServer: TfrxHTTPServer read FWebServer;
published
procedure Loaded; override;
property Active: Boolean read FActive write SetActive;
property AllowIP: TStrings read FAllow write FAllow;
property DenyIP: TStrings read FDeny write FDeny;
property PrintPDF: Boolean read FPDFPrint write FPDFPrint;
property Print: Boolean read FPrint write FPrint;
property OnGetReport: TfrxServerGetReportEvent read FGetReport
write FGetReport;
property OnGetVariables: TfrxServerGetVariablesEvent read FGetVariables
write FGetVariables;
property OnAfterBuildReport: TfrxServerAfterBuildReport read FBuildReport
write FBuildReport;
property SocketOpen: Boolean read FSocketOpen write FSocketOpen;
property ConfigFileName: String read FConfigFileName write FConfigFileName;
end;
TfrxHTTPServer = class(TServerSocket)
private
FBasePath: String;
FGzip: Boolean;
FMainDocument: String;
FNoCacheHeader: Boolean;
FParentReportServer: TfrxReportServer;
FReportPath: String;
FSocketTimeOut: Integer;
FMaxHTTPHeaderSize: Integer;
FMaxContentSize: Int64;
procedure ClientAccept(Sender: TObject; Socket: TCustomWinSocket);
procedure ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
procedure ClientError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure GetThread(Sender: TObject; ClientSocket: TServerClientWinSocket;
var SocketThread: TServerClientThread);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property BasePath: String read FBasePath write FBasePath;
property Gzip: Boolean read FGzip write FGzip;
property MainDocument: String read FMainDocument write FMainDocument;
property NoCacheHeader: Boolean read FNoCacheHeader write FNoCacheHeader;
property ParentReportServer: TfrxReportServer read FParentReportServer
write FParentReportServer;
property ReportPath: String read FReportPath write FReportPath;
property SocketTimeOut: Integer read FSocketTimeOut write FSocketTimeOut;
end;
TfrxServerSession = class(TServerClientThread)
private
FAuthNeeded: Boolean;
FDialog: Boolean;
FDialogSessionId: AnsiString;
FErrorCode: Integer;
FErrorText: AnsiString;
FFormat: TfrxServerFormat;
FGzip: Boolean;
FHeader: AnsiString;
FHost: AnsiString;
FHTTPVersion: AnsiString;
FIsReport: Boolean;
FKeepAlive: boolean;
FMethod: AnsiString;
FMIMEType: AnsiString;
FMultipage: Boolean;
FName: AnsiString;
FReportName: AnsiString;
FGroup: AnsiString;
FNoCacheHeader: Boolean;
FPageNavigator: Boolean;
FPageRange: String;
FParentHTTPServer: TfrxHTTPServer;
FParentReportServer: TfrxReportServer;
FRedirect: Boolean;
FReferer: AnsiString;
FRemoteIP: String;
FReplyBody: TStringList;
FReplyHeader: TStringList;
FRepSession: TfrxReportSession;
FResultPage: String;
FServerReplyData: TStringList;
FSessionId: AnsiString;
FSessionItem: TfrxSessionItem;
FSize: integer;
FUserAgent: AnsiString;
FVariables: TfrxVariables;
FStream: TMemoryStream;
FFileDate: TDateTime;
FCacheId: String;
FPrn: String;
FBrowserPrn: Boolean;
FLogin: String;
FCookie: AnsiString;
FPassword: String;
FReportMessage: String;
FReturnData: AnsiString;
FIsExportRedirect: Boolean;
FInParams: TStringList;
FOutParams: TStringList;
FData: TfrxServerData;
FActive: Boolean;
FAuthInProgress: Boolean;
FAuthResponse: AnsiString;
FAuthFinished: Boolean;
FAuthNewConv: Boolean;
FMaxTokenSize: integer;
FCredHandle: TSecHandle;
FExpire: TTimeStamp;
FToken: cardinal;
FContextHandle: TSecHandle;
FAuthType: String;
FLocalVariables: TfrxServerVariables;
FReportTitle: String;
FmPage: String;
FContentMD5: AnsiString;
FContentLength: Int64;
FIsFP3: Boolean;
FBoundary: AnsiString;
FFormFileName: String;
function InitAuth(const SecPackageName: String): boolean;
function ProcessAuthRequest(AuthRequest: AnsiString; NewConversation: boolean; var AuthResponse: AnsiString;
var ContextHandle: TSecHandle; var AuthFinished: boolean): boolean;
procedure FinalAuth;
function GetCurrentUserToken: {$IFDEF DEL16ORFPC} THandle {$ELSE} cardinal {$ENDIF};
function CheckBadPath: Boolean;
function CheckDeflate(FileName: String): Boolean;
function CheckSSI(FileName: String): Boolean;
function ParseHeaderField(const Field: AnsiString): AnsiString; overload;
function ParseHeaderField(const Field: AnsiString; Const aHeader: AnsiString): AnsiString; overload;
function ParseParam(S: String): String;
function GetMime(s: String): String;
procedure CheckAuth;
procedure CloseSession;
procedure CreateReplyHTTPData;
procedure ErrorLog;
procedure MakeServerReply;
procedure ParseHTTPHeader;
procedure ParseParameters;
procedure SelectFormat(FormatName: String);
procedure IsFP3Content(aContent: AnsiString);
procedure UpdateLocalVariables;
procedure UpdateSessionFName;
procedure WriteLogs;
procedure DoGetVariables;
procedure AddOutData(const Name: String; const Value: String);
procedure WriteHtmlReportIndex(OutStream: TfrxSSIStream);
public
constructor Create(CreateSuspended: Boolean;
ASocket: TServerClientWinSocket);
destructor Destroy; override;
procedure ClientExecute; override;
procedure PrepareReportQuery;
function GetSessionPath: AnsiString;
property NoCacheHeader: Boolean read FNoCacheHeader write FNoCacheHeader;
property ParentHTTPServer: TfrxHTTPServer read FParentHTTPServer
write FParentHTTPServer;
property ParentReportServer: TfrxReportServer read FParentReportServer
write FParentReportServer;
property SessionId: AnsiString read GetSessionPath write FSessionId;
property SessionItem: TfrxSessionItem read FSessionItem write FSessionItem;
property Login: String read FLogin;
property Password: String read FPassword;
property Data: TfrxServerData read FData write FData;
property Active: Boolean read FActive write FActive;
property LocalVariables: TfrxServerVariables read FLocalVariables;
end;
TfrxServerData = class(TObject)
private
FErrorCode: Integer;
FInParams: TStringList;
FOutParams: TStringList;
FStream: TMemoryStream;
FFileName: String;
FHeader: String;
FRepHeader: String;
FHTTPVer: String;
FLastMod: TDateTime;
FExpires: TDateTime;
public
constructor Create;
destructor Destroy; override;
procedure Assign(Source: TfrxServerData);
property InParams: TStringList read FInParams;
property OutParams: TStringList read FOutParams;
property ErrorCode: Integer read FErrorCode write FErrorCode;
property Stream: TMemoryStream read FStream;
property FileName: String read FFileName write FFileName;
property Header: String read FHeader write FHeader;
property RepHeader: String read FRepHeader write FRepHeader;
property HTTPVer: String read FHTTPVer write FHTTPVer;
property Expires: TDateTime read FExpires write FExpires;
property LastMod: TDateTime read FLastMod write FLastMod;
end;
TfrxServerGuard = class(TThread)
private
FTimeOut: Integer;
FServer: TfrxReportServer;
FListTimeOut: Integer;
procedure DoLoadConf;
protected
procedure Execute; override;
public
constructor Create(Server: TfrxReportServer);
destructor Destroy; override;
property TimeOut: Integer read FTimeOut write FTimeOut;
property ListTimeOut: Integer read FListTimeOut write FListTimeOut;
end;
const
MAX_IE_GZIP = 4096;
SERVER_NAME = 'FastReport VCL Enterprise'{$IFDEF FR_FIB} + ' Firebird edition'{$ENDIF};
SERVER_VERSION = {$I frxVersion.inc};
SERVER_DATA = '';
SID_SIGN = 'sid_f';
SID_STORE = 'store_';
implementation
uses frxUtils, frxFileUtils, SyncObjs, StrUtils, frxMutex{$IFNDEF Linux}, ComObj{$ENDIF};
const
SERVER_COPY = '© Copyright 1998-2020 by Fast Reports Inc.';
METHOD_GET = 'GET';
METHOD_POST = 'POST';
HTML = 'text/html';
ERR_UNKNOWN_METHOD = '1';
ERR_OK = '0';
SECPKG_CRED_INBOUND = $00000001;
SECBUFFER_VERSION = 0;
SECBUFFER_TOKEN = 2;
SECURITY_NATIVE_DREP = $00000010;
SEC_I_COMPLETE_NEEDED = HRESULT($00090313);
SEC_I_COMPLETE_AND_CONTINUE = HRESULT($00090314);
SEC_I_CONTINUE_NEEDED = HRESULT($00090312);
NameSamCompatible = 2;
secur32 = 'secur32.dll';
MAX_HTTP_HEADER_SIZE = 16384;
type
TSecGetKeyFn = procedure (
Arg: Pointer;
Principal: Pointer;
KeyVer: Cardinal;
var Key: Pointer;
var Status: Cardinal); stdcall;
{$IFNDEF Linux}
{$IFDEF WIN64}
TfrxAcceptSecurityContext = function (phCredential: PCredHandle; phContext: PCtxtHandle;
pInput: PSecBufferDesc; fContextReq, TargetDataRep: Cardinal;
phNewContext: PCtxtHandle; pOutput: PSecBufferDesc; var pfContextAttr: Cardinal;
ptsExpiry: PTimeStamp): Cardinal; stdcall;
TfrxCompleteAuthToken = function (phContext: PCtxtHandle; pToken: PSecBufferDesc): Cardinal; stdcall;
TfrxImpersonateSecurityContext = function(phContext: PCtxtHandle): Cardinal; stdcall;
TfrxRevertSecurityContext = function (phContext: PCtxtHandle): Cardinal; stdcall;
TfrxQuerySecurityPackageInfo = function (pszPackageName: PChar;
var ppPackageInfo: PSecPkgInfo): Cardinal; stdcall;
TfrxAcquireCredentialsHandle = function (pszPrincipal, pszPackage: PChar;
fCredentialUse: Cardinal; pvLogonId, pAuthData: Pointer;
pGetKeyFn: TSecGetKeyFn; pvGetKeyArgument: Pointer; phCredential: PCredHandle;
var ptsExpiry: TTimeStamp): Cardinal; stdcall;
TfrxFreeCredentialsHandle = function (phCredential: PCredHandle): Cardinal; stdcall;
TfrxFreeContextBuffer = function (pvContextBuffer: Pointer): Cardinal; stdcall;
TfrxGetUserNameEx = function (NameFormat: cardinal; lpNameBuffer: PChar;
var nSize: cardinal): ByteBool; stdcall;
{$ENDIF}
function AcceptSecurityContext(phCredential: PCredHandle; phContext: PCtxtHandle;
pInput: PSecBufferDesc; fContextReq, TargetDataRep: Cardinal;
phNewContext: PCtxtHandle; pOutput: PSecBufferDesc; var pfContextAttr: Cardinal;
ptsExpiry: PTimeStamp): Cardinal; stdcall; forward;
function CompleteAuthToken(phContext: PCtxtHandle; pToken: PSecBufferDesc): Cardinal; stdcall; forward;
function ImpersonateSecurityContext(phContext: PCtxtHandle): Cardinal; stdcall; forward;
function RevertSecurityContext(phContext: PCtxtHandle): Cardinal; stdcall; forward;
function QuerySecurityPackageInfo(pszPackageName: PChar;
var ppPackageInfo: PSecPkgInfo): Cardinal; stdcall; forward;
function AcquireCredentialsHandle(pszPrincipal, pszPackage: PChar;
fCredentialUse: Cardinal; pvLogonId, pAuthData: Pointer;
pGetKeyFn: TSecGetKeyFn; pvGetKeyArgument: Pointer; phCredential: PCredHandle;
var ptsExpiry: TTimeStamp): Cardinal; stdcall; forward;
function FreeCredentialsHandle(phCredential: PCredHandle): Cardinal; stdcall; forward;
function FreeContextBuffer(pvContextBuffer: Pointer): Cardinal; stdcall; forward;
function GetUserNameEx(NameFormat: cardinal; lpNameBuffer: PChar;
var nSize: cardinal): ByteBool; stdcall; forward;
{$ENDIF}
var
ServCS: TCriticalSection;
{$IFNDEF Linux}
{$IFDEF WIN64}
_AcceptSecurityContext: TfrxAcceptSecurityContext;
_CompleteAuthToken: TfrxCompleteAuthToken;
_ImpersonateSecurityContext: TfrxImpersonateSecurityContext;
_RevertSecurityContext: TfrxRevertSecurityContext;
_QuerySecurityPackageInfo: TfrxQuerySecurityPackageInfo;
_AcquireCredentialsHandle: TfrxAcquireCredentialsHandle;
_FreeCredentialsHandle: TfrxFreeCredentialsHandle;
_FreeContextBuffer: TfrxFreeContextBuffer;
_GetUserNameEx: TfrxGetUserNameEx;
{$ELSE}
_AcceptSecurityContext: Pointer;
_CompleteAuthToken: Pointer;
_ImpersonateSecurityContext: Pointer;
_RevertSecurityContext: Pointer;
_QuerySecurityPackageInfo: Pointer;
_AcquireCredentialsHandle: Pointer;
_FreeCredentialsHandle: Pointer;
_FreeContextBuffer: Pointer;
_GetUserNameEx: Pointer;
{$ENDIF}
procedure GetProcedureAddress(var P: Pointer; const ModuleName, ProcName: string);
var ModuleHandle: HMODULE;
begin
if not Assigned(P) then
begin
ModuleHandle := GetModuleHandle(PChar(ModuleName));
if ModuleHandle = 0 then
begin
ModuleHandle := LoadLibrary(PChar(ModuleName));
if ModuleHandle = 0 then
raise Exception.Create('Library not found: ' + ModuleName);
end;
P := GetProcAddress(ModuleHandle, PChar(ProcName));
if not Assigned(P) then
raise Exception.Create('Function not found: ' + ModuleName + '.' + ProcName);
end;
end;
{$IFNDEF Delphi12}
{$WARNINGS OFF}
{$ENDIF}
{$IFDEF WIN64}
function AcceptSecurityContext(phCredential: PCredHandle; phContext: PCtxtHandle;
pInput: PSecBufferDesc; fContextReq, TargetDataRep: Cardinal;
phNewContext: PCtxtHandle; pOutput: PSecBufferDesc; var pfContextAttr: Cardinal;
ptsExpiry: PTimeStamp): Cardinal; stdcall;
begin
GetProcedureAddress(@_AcceptSecurityContext, secur32, 'AcceptSecurityContext');
if @_AcceptSecurityContext <> nil then
Result := _AcceptSecurityContext(phCredential, phContext,
pInput, fContextReq, TargetDataRep,
phNewContext, pOutput, pfContextAttr, ptsExpiry);
end;
function CompleteAuthToken(phContext: PCtxtHandle; pToken: PSecBufferDesc): Cardinal; stdcall;
begin
GetProcedureAddress(@_CompleteAuthToken, secur32, 'CompleteAuthToken');
if @_CompleteAuthToken <> nil then
Result := _CompleteAuthToken(phContext, pToken);
end;
function ImpersonateSecurityContext(phContext: PCtxtHandle): Cardinal; stdcall;
begin
GetProcedureAddress(@_ImpersonateSecurityContext, secur32, 'ImpersonateSecurityContext');
if @_ImpersonateSecurityContext <> nil then
Result := _ImpersonateSecurityContext(phContext);
end;
function RevertSecurityContext(phContext: PCtxtHandle): Cardinal; stdcall;
begin
GetProcedureAddress(@_RevertSecurityContext, secur32, 'RevertSecurityContext');
if @_RevertSecurityContext <> nil then
Result := _RevertSecurityContext(phContext);
end;
function QuerySecurityPackageInfo(pszPackageName: PChar;
var ppPackageInfo: PSecPkgInfo): Cardinal; stdcall;
begin
GetProcedureAddress(@_QuerySecurityPackageInfo, secur32, 'QuerySecurityPackageInfoA');
if @_QuerySecurityPackageInfo <> nil then
Result := _QuerySecurityPackageInfo(pszPackageName, ppPackageInfo);
end;
function AcquireCredentialsHandle(pszPrincipal, pszPackage: PChar;
fCredentialUse: Cardinal; pvLogonId, pAuthData: Pointer;
pGetKeyFn: TSecGetKeyFn; pvGetKeyArgument: Pointer; phCredential: PCredHandle;
var ptsExpiry: TTimeStamp): Cardinal; stdcall;
begin
GetProcedureAddress(@_AcquireCredentialsHandle, secur32, 'AcquireCredentialsHandleA');
if @_AcquireCredentialsHandle <> nil then
Result := _AcquireCredentialsHandle(pszPrincipal, pszPackage,
fCredentialUse, pvLogonId, pAuthData,
pGetKeyFn, pvGetKeyArgument, phCredential, ptsExpiry);
end;
function FreeCredentialsHandle(phCredential: PCredHandle): Cardinal; stdcall;
begin
GetProcedureAddress(@_FreeCredentialsHandle, secur32, 'FreeCredentialsHandle');
if @_FreeCredentialsHandle <> nil then
Result := _FreeCredentialsHandle(phCredential);
end;
function FreeContextBuffer(pvContextBuffer: Pointer): Cardinal; stdcall;
begin
GetProcedureAddress(@_FreeContextBuffer, secur32, 'FreeContextBuffer');
if @_FreeContextBuffer <> nil then
Result := _FreeContextBuffer(pvContextBuffer);
end;
function GetUserNameEx(NameFormat: cardinal; lpNameBuffer: PChar;
var nSize: cardinal): ByteBool; stdcall;
begin
GetProcedureAddress(@_GetUserNameEx, secur32, 'GetUserNameExA');
if @_GetUserNameEx <> nil then
Result := _GetUserNameEx(NameFormat, lpNameBuffer, nSize);
end;
{$ELSE}
function FreeContextBuffer;
begin
GetProcedureAddress(_FreeContextBuffer, secur32, 'FreeContextBuffer');
asm
mov esp, ebp
pop ebp
jmp [_FreeContextBuffer]
end;
end;
function FreeCredentialsHandle;
begin
GetProcedureAddress(_FreeCredentialsHandle, secur32, 'FreeCredentialsHandle');
asm
mov esp, ebp
pop ebp
jmp [_FreeCredentialsHandle]
end;
end;
function AcquireCredentialsHandle;
begin
GetProcedureAddress(_AcquireCredentialsHandle, secur32, 'AcquireCredentialsHandleA');
asm
mov esp, ebp
pop ebp
jmp [_AcquireCredentialsHandle]
end;
end;
function AcceptSecurityContext;
begin
GetProcedureAddress(_AcceptSecurityContext, secur32, 'AcceptSecurityContext');
asm
mov esp, ebp
pop ebp
jmp [_AcceptSecurityContext]
end;
end;
function CompleteAuthToken;
begin
GetProcedureAddress(_CompleteAuthToken, secur32, 'CompleteAuthToken');
asm
mov esp, ebp
pop ebp
jmp [_CompleteAuthToken]
end;
end;
function ImpersonateSecurityContext;
begin
GetProcedureAddress(_ImpersonateSecurityContext, secur32, 'ImpersonateSecurityContext');
asm
mov esp, ebp
pop ebp
jmp [_ImpersonateSecurityContext]
end;
end;
function RevertSecurityContext;
begin
GetProcedureAddress(_RevertSecurityContext, secur32, 'RevertSecurityContext');
asm
mov esp, ebp
pop ebp
jmp [_RevertSecurityContext]
end;
end;
function QuerySecurityPackageInfo;
begin
GetProcedureAddress(_QuerySecurityPackageInfo, secur32, 'QuerySecurityPackageInfoA');
asm
mov esp, ebp
pop ebp
jmp [_QuerySecurityPackageInfo]
end;
end;
function GetUserNameEx;
begin
GetProcedureAddress(_GetUserNameEx, secur32, 'GetUserNameExA');
asm
mov esp, ebp
pop ebp
jmp [_GetUserNameEx]
end;
end;
{$ENDIF}
{$ENDIF}
{$IFNDEF Delphi12}
{$WARNINGS ON}
{$ENDIF}
{ TfrxReportServer }
function TfrxReportServer.LoadConfigs: Boolean;
begin
result := ServerConfig.LoadFromFile(frxGetAbsPathDir(FConfigFileName, ServerConfig.ConfigFolder)) <> E_FAIL;
if result then
ServerUsers.LoadFromFile(frxGetAbsPathDir(ServerConfig.GetValue('server.security.usersfile'), ServerConfig.ConfigFolder));
end;
procedure TfrxReportServer.Loaded;
begin
if csLoading in ComponentState then
Initialize;
inherited;
end;
procedure TfrxReportServer.Initialize;
var
s: String;
templates_path, root_path, config_path: String;
begin
if FConfigFileName = '' then
FConfigFileName := 'config.xml';
FConfigLoaded := LoadConfigs;
if FConfigLoaded then
begin
LogWriter := TfrxServerLog.Create;
templates_path := frxGetAbsPathDir(ServerConfig.GetValue('server.http.templatespath'), ServerConfig.ConfigFolder);
root_path := frxGetAbsPathDir(ServerConfig.GetValue('server.http.rootpath'), ServerConfig.ConfigFolder);
CopyFiles(templates_path, root_path, '*.js *.css', '', false);
s := 'FrImages';
if not DirectoryExists(root_path + s) then
CreateDir(root_path + s);
CopyFiles(templates_path + s, root_path + s, '*.*', '', true);
LogWriter.MaxLogSize := StrToInt(ServerConfig.GetValue('server.logs.rotatesize'));
LogWriter.MaxLogFiles := StrToInt(ServerConfig.GetValue('server.logs.rotatefiles'));
LogWriter.LogDir := frxGetAbsPathDir(ServerConfig.GetValue('server.logs.path'), ServerConfig.ConfigFolder);
LogWriter.AddLevel(ServerConfig.GetValue('server.logs.errorlog'));
LogWriter.AddLevel(ServerConfig.GetValue('server.logs.accesslog'));
LogWriter.AddLevel(ServerConfig.GetValue('server.logs.refererlog'));
LogWriter.AddLevel(ServerConfig.GetValue('server.logs.agentlog'));
LogWriter.AddLevel(ServerConfig.GetValue('server.logs.serverlog'));
LogWriter.AddLevel(ServerConfig.GetValue('server.logs.schedulerlog'));
FBusy := False;
{
FADOConnection := TADOConnection.Create(nil);
FADOConnection.LoginPrompt := False;
FADOConnection.ConnectionString := ServerConfig.GetValue('server.database.connectionstring');
FADOConnection.Name := 'ADOConnection';
FADOComponents := TfrxADOComponents.Create(nil);
FADOComponents.DefaultDatabase := FADOConnection;
}
{$IFDEF FR_FIB}
FfrxFIBConnection := TfrxFIBDatabase.Create(nil);
FfrxFIBConnection.FromString(ServerDB.GetFIBConnectionString(ServerConfig.GetValue('server.database.connection')));
FFIBComponents := TfrxFIBComponents.Create(nil);
FFIBComponents.DefaultDatabase := FfrxFIBConnection.Database;
try
FfrxFIBConnection.Database.SQLDialect := 3;
FfrxFIBConnection.Database.Open;
except
on E:Exception do
begin
LogWriter.Write(SERVER_LEVEL, 'DATABASE ERROR! ' + E.Message + #13#10);
end;
end;
{$ENDIF}
FAllow := TfrxStringListMask.Create;
FDeny := TfrxStringListMask.Create;
s := frxGetAbsPathDir(ServerConfig.GetValue('server.security.allowfile'), ServerConfig.ConfigFolder);
if FileExists(s) then
FAllow.LoadFromFile(s{$IFDEF Delphi12},TEncoding.UTF8{$ENDIF});
s := frxGetAbsPathDir(ServerConfig.GetValue('server.security.denyfile'), ServerConfig.ConfigFolder);
if FileExists(s) then
FDeny.LoadFromFile(s{$IFDEF Delphi12},TEncoding.UTF8{$ENDIF});
FTotals := TStringList.Create;
LogWriter.Write(SERVER_LEVEL, DateTimeToStr(Now) + #9'Started');
LogWriter.Write(SERVER_LEVEL, 'Logs path:' + #9 + frxGetAbsPathDir(ServerConfig.GetValue('server.logs.path'), ServerConfig.ConfigFolder));
LogWriter.Write(SERVER_LEVEL, 'Reports path:' + #9 + frxGetAbsPathDir(ServerConfig.GetValue('server.reports.path'), ServerConfig.ConfigFolder));
LogWriter.Write(SERVER_LEVEL, 'Reports cache path:' + #9 + frxGetAbsPathDir(ServerConfig.GetValue('server.cache.path'), ServerConfig.ConfigFolder));
LogWriter.Write(SERVER_LEVEL, 'Root path:' + #9 + root_path);
config_path := '';
if ExtractFileName(FConfigFileName) = FConfigFileName then
config_path := GetAppPath;
if FileExists(config_path + FConfigFileName) then
LogWriter.Write(SERVER_LEVEL, 'Config file:' + #9 + FConfigFileName)
else
LogWriter.Write(SERVER_LEVEL, 'ERROR! Config file ' + FConfigFileName + ' not found!');
SessionManager := TfrxSessionManager.Create;
FWebServer := TfrxHTTPServer.Create(nil);
FWebServer.ParentReportServer := Self;
ReportCache := TfrxServerCache.Create;
ResultCache := TfrxResultCache.Create(root_path, SID_STORE);
ServerStatistic := TfrxServerStatistic.Create;
FVariables := TfrxServerVariables.Create;
ServerPrinter := TfrxServerPrinter.Create;
ServerUsers.LoadFromFile(ServerConfig.GetValue('server.security.usersfile'));
FVariables.AddVariable('SERVER_NAME', ServerConfig.GetValue('server.name'));
FVariables.AddVariable('SERVER_COPYRIGHT', SERVER_COPY);
FVariables.AddVariable('SERVER_SOFTWARE', SERVER_VERSION);
FVariables.AddVariable('SERVER_LAST_UPDATE', SERVER_DATA);
FPDFPrint := False;
FPrint := True;
Active := False;
ReportCache.Clear;
ResultCache.Clear;
ReportsList := TfrxServerReportsList.Create;
LogWriter.Active := ServerConfig.GetBool('server.logs.active');
FGuard := TfrxServerGuard.Create(Self);
end;
end;
constructor TfrxReportServer.CreateWithRoot(const Folder: String; const Socket: Boolean);
begin
inherited Create(nil);
FSocketOpen := Socket;
FConfigLoaded := false;
ServerConfig.ConfigFolder := Folder;
if not(csLoading in ComponentState) then
Initialize;
end;
constructor TfrxReportServer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FConfigLoaded := false;
ServerConfig.ConfigFolder := GetAppPath;
FSocketOpen := True;
if not((AOwner <> nil) and (csLoading in AOwner.ComponentState)) then
Initialize;
end;
destructor TfrxReportServer.Destroy;
begin
if FConfigLoaded then
begin
// FADOConnection.Free;
// FADOComponents.Free;
FWebServer.Free;
ReportCache.Terminate;
ResultCache.Terminate;
PMessages;
ReportCache.Free;
ResultCache.Free;
ServerPrinter.Terminate;
PMessages;
ServerPrinter.Free;
FGuard.Terminate;
PMessages;
FGuard.Free;
FAllow.Free;
FDeny.Free;
LogWriter.Write(SERVER_LEVEL, DateTimeToStr(Now) + #9'Stopped'#9 + #13#10 + Totals.Text);
LogWriter.Flush;
if Active then
Active := False;
ServerStatistic.Free;
SessionManager.Free;
FTotals.Free;
FVariables.Free;
LogWriter.Free;
ReportsList.Free;
end;
inherited;
end;
procedure TfrxReportServer.SetActive(const Value: Boolean);
begin
if FConfigLoaded and SocketOpen then
begin
try
FWebServer.Active := Value;
except
on E:Exception do
begin
if Value then
LogWriter.Write(SERVER_LEVEL, DateTimeToStr(Now) + #9'Port open failed. ' + E.Message + #13#10)
else
LogWriter.Write(SERVER_LEVEL, DateTimeToStr(Now) + #9'Port close failed. ' + E.Message + #13#10)
end;
end;
end;
if FConfigLoaded and (FWebServer.Active = Value) then
FActive := Value;
end;
procedure TfrxReportServer.Open;
begin
if FConfigLoaded and ServerConfig.GetBool('server.security.reportslist') then
begin
ReportsList.ReportsPath := frxGetAbsPathDir(ServerConfig.GetValue('server.reports.path'), ServerConfig.ConfigFolder);
ReportsList.BuildListOfReports;
Active := True;
end;
end;
procedure TfrxReportServer.Close;
begin
if FConfigLoaded then
begin
Active := False;
ReportCache.Clear;
ResultCache.Clear;
end;
end;
function TfrxReportServer.GetTotals: TStrings;
begin
FTotals.Clear;
FTotals.Add('Uptime: ' + ServerStatistic.FormatUpTime);
FTotals.Add('Total sessions: ' + IntToStr(ServerStatistic.TotalSessionsCount));
FTotals.Add('Total reports: ' + IntToStr(ServerStatistic.TotalReportsCount));
FTotals.Add('Total cache hits: ' + IntToStr(ServerStatistic.TotalCacheHits));
FTotals.Add('Total errors: ' + IntToStr(ServerStatistic.TotalErrors));
FTotals.Add('Max sessions: ' + IntToStr(ServerStatistic.MaxSessionsCount));
FTotals.Add('Max reports: ' + IntToStr(ServerStatistic.MaxReportsCount));
Result := FTotals;
end;
procedure TfrxReportServer.StatToVar;
begin
FVariables.AddVariable('SERVER_UPTIME', ServerStatistic.FormatUpTime);
FVariables.AddVariable('SERVER_TOTAL_SESSIONS', IntToStr(ServerStatistic.TotalSessionsCount));
FVariables.AddVariable('SERVER_TOTAL_REPORTS', IntToStr(ServerStatistic.TotalReportsCount));
FVariables.AddVariable('SERVER_TOTAL_ERRORS', IntToStr(ServerStatistic.TotalErrors));
FVariables.AddVariable('SERVER_TOTAL_CACHE', IntToStr(ServerStatistic.TotalCacheHits));
FVariables.AddVariable('SERVER_MAX_SESSIONS', IntToStr(ServerStatistic.MaxSessionsCount));
FVariables.AddVariable('SERVER_MAX_REPORTS', IntToStr(ServerStatistic.MaxReportsCount));
FVariables.AddVariable('SERVER_CURRENT_SESSIONS', IntToStr(ServerStatistic.CurrentSessionsCount));
FVariables.AddVariable('SERVER_CURRENT_REPORTS', IntToStr(ServerStatistic.CurrentReportsCount));
end;
procedure TfrxReportServer.Get(Data: TfrxServerData);
var
Session: TfrxServerSession;
Socket: TServerClientWinSocket;
begin
Socket := TServerClientWinSocket.Create(-1, FWebServer.Socket);
FWebServer.GetThread(nil, Socket, TServerClientThread(Session));
Session.Data := Data;
Session.Active := True;
Session.Resume;
while Session.Active do
Sleep(10);
SessionManager.CompleteSessionId(String(TCustomWinSocket(Socket).Data));
end;
{ TfrxHTTPServer }
constructor TfrxHTTPServer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Active := False;
ServerType := stThreadBlocking;
Port := StrToInt(ServerConfig.GetValue('server.http.port'));
FGzip := ServerConfig.GetBool('server.http.compression');
FMainDocument := ServerConfig.GetValue('server.http.indexfile');
FBasePath := frxGetAbsPathDir(ServerConfig.GetValue('server.http.rootpath'), ServerConfig.ConfigFolder);
FSocketTimeOut := StrToInt(ServerConfig.GetValue('server.http.sockettimeout'));
FNoCacheHeader := ServerConfig.GetBool('server.http.nocacheheader');
FMaxHTTPHeaderSize := ServerConfig.GetNumber('server.http.headermaxsize');
if (FMaxHTTPHeaderSize > MAX_HTTP_HEADER_SIZE) or (FMaxHTTPHeaderSize <= 0) then
FMaxHTTPHeaderSize := MAX_HTTP_HEADER_SIZE;
FMaxContentSize := ServerConfig.GetNumber('server.http.contentmaxsize') * 1024 * 1024; // MB
OnClientError := ClientError;
OnClientDisconnect := ClientDisconnect;
OnAccept := ClientAccept;
OnGetThread := GetThread;
LogWriter.Write(SERVER_LEVEL, DateTimeToStr(Now) + #9'HTTP server created');
end;
destructor TfrxHTTPServer.Destroy;
begin
LogWriter.Write(SERVER_LEVEL, DateTimeToStr(Now) + #9'HTTP server closed');
inherited;
end;
procedure TfrxHTTPServer.ClientError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
if (ErrorCode <> 10053) and (ErrorCode <> 10054) then
begin
LogWriter.Write(ERROR_LEVEL, DateTimeToStr(Now) + #9 + Socket.RemoteAddress + #9 + GetSocketErrorText(ErrorCode));
LogWriter.ErrorReached;
end;
ErrorCode := 0;
SessionManager.CompleteSessionId(String(TCustomWinSocket(Socket).Data));
Socket.Close;
end;
procedure TfrxHTTPServer.ClientDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
SessionManager.CompleteSessionId(String(TCustomWinSocket(Socket).Data));
end;
procedure TfrxHTTPServer.GetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
var
MaxSessions: Integer;
SessionTimeout: Integer;
begin
try
MaxSessions := ServerConfig.GetNumber('server.http.maxsessions');
SessionTimeout := ServerConfig.GetNumber('server.http.sessiontimeout') * 1000;
if MaxSessions > 0 then
begin
while LogWriter.CurrentSessions > MaxSessions do
begin
if SessionTimeout = 0 then
begin
LogWriter.Write(ERROR_LEVEL, DateTimeToStr(Now) + #9 + ClientSocket.RemoteAddress + ' Maximum count of sessions has been reached.. ');
exit;
end
else
Dec(SessionTimeout);
PMessages;
end;
end;
SocketThread := TfrxServerSession.Create(True, ClientSocket);
SocketThread.FreeOnTerminate := True;
SocketThread.KeepInCache := False;
TfrxServerSession(SocketThread).ParentReportServer := ParentReportServer;
TfrxServerSession(SocketThread).ParentHTTPServer := Self;
if ClientSocket <> nil then
ClientSocket.Data := PChar(TfrxServerSession(SocketThread).SessionId);
TfrxServerSession(SocketThread).SessionItem := SessionManager.AddSession(TfrxServerSession(SocketThread).SessionId, TCustomWinSocket(ClientSocket));
if ParentReportServer.SocketOpen then
SocketThread.Resume;
FParentReportServer.StatToVar;
except
on E:Exception do
LogWriter.Write(ERROR_LEVEL, DateTimeToStr(Now) + #9 + ClientSocket.RemoteAddress + ' client session creation error. ' + E.Message);
end;
end;
procedure TfrxHTTPServer.ClientAccept(Sender: TObject;
Socket: TCustomWinSocket);
begin
if ParentReportServer.DenyIP.IndexOf(Socket.RemoteAddress) <> -1 then
begin
LogWriter.Write(ERROR_LEVEL, DateTimeToStr(Now) + #9 + Socket.RemoteAddress + ' denial of client connection');
Socket.Close;
end
else if (ParentReportServer.AllowIP.Count > 0) and
(ParentReportServer.AllowIP.IndexOf(Socket.RemoteAddress) = -1) then
begin
LogWriter.Write(ERROR_LEVEL, DateTimeToStr(Now) + #9 + Socket.RemoteAddress + ' client connection not allowed');
Socket.Close;
end;
end;
{ TfrxServerSession }
constructor TfrxServerSession.Create(CreateSuspended: Boolean; ASocket: TServerClientWinSocket);
begin
inherited Create(CreateSuspended, ASocket);
FSessionId := SID_SIGN + MakeSessionId;
FIsReport := False;
FSize := 0;
FKeepAlive := False;
FRemoteIP := ClientSocket.RemoteAddress;
FServerReplyData := TStringList.Create;
FReplyHeader := TStringList.Create;
FReplyBody := TStringList.Create;
FFormat := sfHTM;
FPageRange := '';
FGzip := False;
FResultPage := '';
FRedirect := False;
FStream := TMemoryStream.Create;
FInParams := TStringList.Create;
FOutParams := TStringList.Create;
{$IFDEF FPC}
FServerReplyData.LineBreak := #13#10;
FReplyHeader.LineBreak := #13#10;
FReplyBody.LineBreak := #13#10;
FOutParams.LineBreak := #13#10;
FInParams.LineBreak := #13#10;
{$ENDIF}
FData := nil;
FAuthInProgress := False;
FAuthFinished := False;
FAuthNewConv := True;
FToken := 0;
FLocalVariables := TfrxServerVariables.Create;
end;
destructor TfrxServerSession.Destroy;
begin
FLocalVariables.Free;
FInParams.Free;
FOutParams.Free;
FStream.Free;
FServerReplyData.Free;
FReplyHeader.Free;
FReplyBody.Free;
inherited;
end;
function TfrxServerSession.ParseHeaderField(const Field: AnsiString): AnsiString;
begin
Result := ParseHeaderField(Field, FHeader);
end;
function TfrxServerSession.ParseHeaderField(const Field: AnsiString; Const aHeader: AnsiString): AnsiString;
var
i: integer;
s: Ansistring;
begin
i := Pos(Field, aHeader);
Result := '';
if i > 0 then
begin
s := Copy(aHeader, i + Length(Field), Length(aHeader) - i + Length(Field));
i := Pos(AnsiString(#13#10), s);
if i > 0 then
Result := Copy(s, 1, i - 1);
end;
end;
procedure TfrxServerSession.ParseHTTPHeader;
var
i, j: Integer;
ContentType, s: AnsiString;
function GetBoundary(aValue: AnsiString): AnsiString;
var
sPos, Cnt: Integer;
begin
Result := '';
sPos := Pos('boundary=', aValue);
if (i > 0) and (sPos > 0) then
begin
Cnt := PosEx(';', aValue, sPos);
Inc(sPos, 9);
if Cnt <= 0 then
Cnt := Length(aValue) - sPos;
Result := Copy(aValue, sPos, Cnt);
end;
end;
begin
FMethod := ERR_UNKNOWN_METHOD;
FErrorCode := 0;
FReturnData := '';
i := Pos(AnsiString(' '), FHeader);
FMethod := Copy(FHeader, 1, i - 1);
if (FMethod = METHOD_GET) or (FMethod = METHOD_POST) then
begin
i := Pos(AnsiString('/'), FHeader);
if i > 0 then
begin
FName := Trim(String(Copy(FHeader, i + 1, Pos(AnsiString('HTTP'), FHeader) - i - 2)));
FName := HTML2Str(FName);
FHTTPVersion := Copy(FHeader, Pos(AnsiString('HTTP/'), FHeader), 8);
FHost := ParseHeaderField('Host: ');
//FKeepAlive := ParseHeaderField('Connection: ') = 'keep-alive';
FKeepAlive := False;
FReferer := ParseHeaderField('Referer: ');
FUserAgent := ParseHeaderField('User-Agent: ');
FContentMD5 := ParseHeaderField('Content-MD5: ');
TryStrToInt64(ParseHeaderField('Content-Length: '), FContentLength);
if ServerConfig.GetBool('server.security.cgiauth') then
FLogin := ParseHeaderField('UserName: ')
else if ServerConfig.GetBool('server.security.remoteauth') then
FLogin := ParseHeaderField('RemoteUserName: ')
else if ServerConfig.GetBool('server.security.cookieauth') then
begin
FCookie := ParseHeaderField('Cookie: ');
s := 'LI_USR';
i := Pos(AnsiString(s), FCookie);
j := i + Length(s) + 1;
if (i > 0) then
begin
FLogin := '';
while((FCookie[j] <> ';') and (j <= Length(FCookie))) do
begin
FLogin := FLogin + FCookie[j];
Inc(j);
end;
end;
end;
ContentType := ParseHeaderField('Content-Type: ');
{ looking for better detection solution }
IsFP3Content(ContentType);
FBoundary := GetBoundary(ContentType);
s := ParseHeaderField('Accept-Encoding: ');
if Length(s) > 0 then
if (Pos('gzip', LowerCase(s)) > 0) and (FParentHTTPServer.Gzip) then
FGzip := True;
CheckAuth;
WriteLogs;
end;
end;
end;
procedure TfrxServerSession.ParseParameters;
var
i, j: Integer;
s, TempName: Ansistring;
P, V: AnsiString;
RepName, Redir: AnsiString;
begin
i := -1;
if not FAuthNeeded then
begin
FKeepAlive := False;
if (FMethod = METHOD_GET) or ((FMethod = METHOD_POST) and FIsFP3) then
begin
i := Pos('?', FName);
if i > 0 then
begin
TempName := Copy(FName, 1, i - 1);
FName := Copy(FName, i + 1, Length(FName) - i);
end;
end else
{ remark : have no idia what this legacy code used for , remove it after testing }
if (FMethod = METHOD_POST) and (FStream.Size > 0) then
begin
SetLength(FName, FStream.Size);
FStream.Position := 0;
FStream.ReadBuffer(FName[1], FStream.Size); // check
end;
s := ParseParam('getvariable');
if Length(s) = 0 then
begin
RepName := ParseParam('report');
{$IFDEF FPC}
{$IFDEF Linux}
RepName := StringReplace(RepName, '\', '/', [rfReplaceAll]);
{$ELSE}
RepName := StringReplace(RepName, '/', '\', [rfReplaceAll]);
{$ENDIF}
{$ENDIF}
Redir := ParseParam('dialog_redirect');
if Redir = '' then
begin
Redir := ParseParam('export_redirect');
if Redir <> '' then
FIsExportRedirect := True;
end;
if FIsFP3 and (FFormFileName <> '') then
RepName := FFormFileName;
FDialogSessionId := ParseParam('sessionid');
FCacheId := ParseParam('cacheid');
FBrowserPrn := ParseParam('print') = '1';
FPrn := ParseParam('prn');
if (FPrn = '1') and ServerConfig.GetBool('server.http.allowprint') then
begin
// print window
FReturnData := ServerPrinter.GetHTML(FCacheId, RepName);
FMIMEType := 'text/html';
end
else
if (FPrn = '2') and ServerConfig.GetBool('server.http.allowprint') then
begin
{$IFDEF DELPHI12}
ServerPrinter.AddPrintJob(FCacheId, ParseParam('printer'), Parseparam('pages'), StrToInt(ParseParam('copies')), ParseParam('collate') = '1', ParseParam('reverse') = '1');
{$ELSE}
ServerPrinter.AddPrintJob(FCacheId, Utf8Decode(ParseParam('printer')), Parseparam('pages'), StrToInt(ParseParam('copies')), ParseParam('collate') = '1', ParseParam('reverse') = '1');
{$ENDIF}
FName := FCacheId + '/index.html';
end
else
if (RepName <> '') and ReportsList.GetGroupMembership(RepName, FGroup) then
begin
if Length(FDialogSessionId) > 0 then
FDialog := True;
s := ParseParam('format');
if Length(s) > 0 then
begin
Redir := '';
SelectFormat(s);
end;
Self.FmPage := ParseParam('mPage');
s := ParseParam('multipage');
if s = '0' then FMultipage := False
else if s = '1' then FMultipage := True
else FMultipage := not ServerConfig.GetBool('server.exports.html.singlepage');
s := ParseParam('pagenav');
if s = '0' then FPageNavigator := False
else if s = '1' then FPageNavigator := True
else FPageNavigator := ServerConfig.GetBool('server.exports.html.navigator');
s := ParseParam('pagerange');
FPageRange := s;
if FBrowserPrn then
begin
FMultipage := false;
FPageNavigator := false;
Redir := '';
end;
FVariables := TfrxVariables.Create;
try
if Pos('=', FName) > 0 then
begin
i := 1;
while i > 0 do
begin
j := 1;
while (j <= i) and (j <> 0) do
begin
i := Pos('=', FName);
j := Pos('&', FName);
if (j < i) and (j <> 0) then
FName := Copy(FName, j + 1, Length(FName) - j);
end;
if i > 0 then
begin
P := Copy(FName, 1, i - 1);
s := ParseParam(P);
{$IFDEF DELPHI12}
V := s;
{$ELSE}
V := UTF8Decode(s);
{$ENDIF}
if V = '' then
V := s;
V := '''' + V + '''';
FVariables[P] := V;
end;
end;
end;
if Redir = '' then
begin
FIsReport := True;
FName := frxGetAbsPathDir(ServerConfig.GetValue('server.reports.path'), ServerConfig.ConfigFolder) + RepName;
FReportName := RepName;
PrepareReportQuery;
end
else
FName := Redir;
finally
FVariables.Free;
end;
end else
if i > 0 then
FErrorCode := 403;
end else
begin
FReturnData := TfrxReportServer(ParentReportServer).Variables.GetValue(s);
if Length(FReturnData) = 0 then
begin
UpdateLocalVariables;
FReturnData := LocalVariables.GetValue(s);
if Length(FReturnData) = 0 then
FErrorCode := 404;
end;
end;
end;
end;
function TfrxServerSession.ParseParam(S: String): String;
var
i, j: integer;
aStrResult : AnsiString;
begin
i := Pos(UpperCase(S) + '=', UpperCase(FName));
if i > 0 then
begin
aStrResult := Copy(FName, i + Length(S) + 1, Length(FName) - i + Length(S) + 1);
j := Pos('&', aStrResult);
if j > 0 then
aStrResult := Copy(aStrResult, 1, j - 1);
Delete(FName, i, Length(S) + Length(aStrResult) + 1);
end else
aStrResult := '';
if Length(FName) > 0 then
begin
i := 1;
while (FName[i] = '&') and (i < Length(FName)) do
Inc(i);
Delete(FName, 1, i - 1);
end;
if aStrResult <> '' then
aStrResult := HTML2Str(aStrResult);
{$IFDEF DELPHI12}
Result := UTF8Decode(aStrResult)
{$ELSE}
Result := aStrResult;
{$ENDIF}
end;
function TfrxServerSession.CheckBadPath: Boolean;
begin
Result := (Pos('..\', FName) > 0) or (Pos('../', FName) > 0);
end;
procedure TfrxServerSession.CreateReplyHTTPData;
var
SearchRec: TSearchRec;
s, sn: String;
Index: Integer;
begin
FServerReplyData.Clear;
FReplyHeader.Clear;
if Length(FReturnData) > 0 then
FErrorCode := 200;
if (FErrorCode = 0) then
if CheckBadPath then
FErrorCode := 403
else if FAuthNeeded then
FErrorCode := 401
else if (Length(FResultPage) > 0) then
begin
if ((FFormat = sfHTM) or (FFormat = sfHTMD)) and (not FDialog) then
begin
FErrorCode := 200;
FRedirect := False;
end
else
if FileExists(FParentHTTPServer.BasePath + FResultPage) then
begin
FErrorCode := 301;
FRedirect := True;
end
end else
begin
if FName = '' then
FName := FParentHTTPServer.MainDocument;
if (FindFirst(FParentHTTPServer.BasePath + FName, faReadOnly + faArchive, SearchRec) = 0) or
(FindFirst(FParentHTTPServer.BasePath + FName + FParentHTTPServer.MainDocument, faReadOnly + faArchive, SearchRec) = 0)
then
begin
FErrorCode := 200;
FSize := SearchRec.Size;
FFileDate := FileDateToDateTime(SearchRec.Time);
end else
FErrorCode := 404;
FindClose(SearchRec);
end;
UpdateSessionFName;
s := ExtractFileExt(FName);
if FMIMEType = '' then
FMIMEType := GetMime(s);
s := '';
if FErrorCode = 401 then
s := ' Unauthorized'
else if FErrorCode = 403 then
s := ' Forbidden';
if FData <> nil then
FData.HTTPVer := FHTTPVersion;
if FData <> nil then
FData.ErrorCode := FErrorCode;
if (FErrorCode = 0 ) and (Length(FReportMessage) > 0) then
begin
FErrorCode := 500;
s := FReportMessage;
end;
FReplyHeader.Add(FHTTPVersion + ' ' + IntToStr(FErrorCode) + s);
if Length(s) = 0 then
begin
sn := 'Server';
FReplyHeader.Add(sn + ': ' + SERVER_NAME);
AddOutData(sn, SERVER_NAME);
if FErrorCode = 200 then
begin
sn := 'Content-Type';
AddOutData(sn, FMIMEType);
FReplyHeader.Add(sn + ': ' + FMIMEType);
if FIsExportRedirect then
begin
sn := 'Content-Disposition';
Index := LastDelimiter('/', FName);
if Index = Length(FName) then
Index := 0;
S := 'inline; filename="' + Copy(FName, Index + 1, Length(FName)) + '"';
AddOutData(sn, S);
FReplyHeader.Add(sn + ': ' + S);
FIsExportRedirect := false;
end;
end;
if (FParentHTTPServer.FNoCacheHeader) and (not FRedirect) then
begin
sn := 'Cache-Control';
s := 'must-revalidate, max-age=0';
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
sn := 'Pragma';
s := 'no-cache';
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
end;
sn := 'Accept-ranges';
s := 'none';
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
sn := 'Last-Modified';
s := DateTimeToRFCDateTime(FFileDate);
AddOutData(sn, s);
FReplyHeader.Add(sn + ':' + s);
sn := 'Expires';
s := DateTimeToRFCDateTime(FFileDate);
if FData <> nil then
begin
FData.Expires := FFileDate;
FData.LastMod := FFileDate;
end;
AddOutData(sn, s);
FReplyHeader.Add(sn + ':' + s);
if FGzip and CheckDeflate(FName) and (FErrorCode = 200) and FParentReportServer.SocketOpen then
begin
sn := 'Content-Encoding';
s := 'gzip';
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s)
end else
FGzip := False;
if FRedirect then
begin
sn := 'Location';
s := 'result?report=' + FReportName;
if FDialogSessionId <> '' then
s := s + '&dialog_redirect='
else
s := s + '&export_redirect=';
s := s + FResultPage;
if (not FIsFP3) then
begin
s := s + '&cacheid=';
if FDialogSessionId <> '' then
s := s + FDialogSessionId
else
s := s + FSessionId;
end;
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
end;
if FIsReport then
begin
sn := 'SessionId';
if FDialogSessionId <> '' then
s := FDialogSessionId
else
s := SessionId;
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
end;
end;
end;
function TfrxServerSession.GetSessionPath: AnsiString;
begin
if (FIsFP3) then
begin
if FContentMD5 = '' then
FContentMD5 := MD5Stream(FStream);
result := SID_STORE + FContentMD5;
end
else
result := FSessionID;
end;
procedure TfrxServerSession.PrepareReportQuery;
var
Path: String;
{$IFNDEF FPC}
SecAtrtrs: TSecurityAttributes;
{$ENDIF}
ReportTimeout: Integer;
MaxReports: Integer;
begin
if FIsReport then
begin
Path := FParentHTTPServer.BasePath + SessionId;
{$IFDEF FPC}
CreateDir(Path);
{$ELSE}
SecAtrtrs.nLength := SizeOf(TSecurityAttributes);
SecAtrtrs.lpSecurityDescriptor := nil;
SecAtrtrs.bInheritHandle := true;
CreateDirectory(PChar(Path), @SecAtrtrs);
{$ENDIF}
if not FDialog then
begin
MaxReports := ServerConfig.GetNumber('server.reports.maxreports');
ReportTimeout := ServerConfig.GetNumber('server.http.sockettimeout') * 1000;
if MaxReports > 0 then
begin
while LogWriter.CurrentReports > MaxReports do
begin
if ReportTimeout = 0 then
begin
FErrorText := 'Maximum count of reports has been reached.';
ErrorLog;
exit;
end
else
Dec(ReportTimeout);
PMessages;
end;
end;
FRepSession := TfrxReportSession.Create;
FRepSession.ParentThread := Self;
FRepSession.NativeClient := Pos('FastReport', FUserAgent) > 0;
FRepSession.Stream := FStream;
FRepSession.IsFP3 := FIsFP3;
FRepSession.ParentReportServer := ParentReportServer;
FRepSession.SessionId := SessionId;
FRepSession.CacheId := FCacheId;
if FIsFP3 then
begin
FRepSession.FileName := FContentMD5;
FStream.Position := 0;
end
else
FRepSession.FileName := FName;
FRepSession.ReportPath := FParentHTTPServer.ReportPath;
FRepSession.IndexFileName := FParentHTTPServer.MainDocument;
FRepSession.RootPath := FParentHTTPServer.BasePath;
FRepSession.PageRange := FPageRange;
FRepSession.Format := FFormat;
FRepSession.mPage := FmPage;
FRepSession.Print := FBrowserPrn;
if Assigned(ParentReportServer.OnGetVariables) then
DoGetVariables;
FRepSession.Variables := FVariables;
FRepSession.FreeOnTerminate := True;
FRepSession.Password := FPassword;
FSessionItem.ReportThread := FRepSession;
FRepSession.PageNav := FPageNavigator;
FRepSession.Multipage := FMultipage;
FRepSession.UserLogin := FLogin;
FRepSession.UserGroup := FGroup;
FRepSession.Resume;
end else
begin
FSessionItem := SessionManager.FindSessionById(FDialogSessionId);
if FSessionItem <> nil then
begin
FRepSession := FSessionItem.ReportThread;
if FRepSession <> nil then
begin
FRepSession.Stream := FStream;
FRepSession.Variables := FVariables;
FRepSession.Continue := True;
while FRepSession.DialogActive and (not Terminated) do
Sleep(25);
end;
end;
end;
if (FRepSession <> nil) and (not Terminated) then
begin
while (not Terminated) and (FRepSession.Active) and (not FRepSession.DialogActive) do
Sleep(10);
if FRepSession.Active and Terminated then
begin
FRepSession.TerminateReport;
// do not close session until report thread is down
//while FRepSession.Active do
// Sleep(10);
end;
if FDialog then
FName := PathDelim + FDialogSessionId + FRepSession.ResultPage
else
begin
FName := PathDelim + SessionId + FRepSession.ResultPage;
end;
FReportTitle := FRepSession.ReportTitle;
if FRepSession.Mime <> '' then
FMIMEType := FRepSession.Mime;
FReportMessage := FRepSession.ReportMessage;
if FRepSession.Auth then
FAuthNeeded := True;
if (not FRepSession.DialogActive) then
if FDialog then
begin
FRepSession.Terminate;
PMessages;
SessionManager.FindSessionById(FDialogSessionId).ReportThread := nil;
end else
SessionManager.FindSessionById(FSessionId).ReportThread := nil;
FRepSession.Readed := True;
end else
FName := '';
FResultPage := StringReplace(FName, '\', '/', [rfReplaceAll]);
FFileDate := Now;
end;
end;
procedure TfrxServerSession.WriteHtmlReportIndex(OutStream: TfrxSSIStream);
var
FTemplate: TfrxServerTemplate;
s, Template: String;
AnsiStr: AnsiString;
begin
Template := '';
FTemplate := TfrxServerTemplate.Create;
try
FTemplate.SetTemplate('index');
FTemplate.Variables.AddVariable('TITLE', FReportTitle);
FTemplate.Variables.AddVariable('SESSION', FSessionId);
if FMultipage then
s := '1.html'
else
if FPageNavigator then
s := 'main.html'
else
s := 'html';
// /FastReport.Export.axd?object=
FTemplate.Variables.AddVariable('INDEX', '/' + SessionId + '/index.' + s);
FTemplate.Prepare;
Template := FTemplate.TemplateStrings.Text;
finally
FTemplate.Free;
end;
AnsiStr := UTF8Encode(Template);
OutStream.Write(AnsiStr[1], Length(AnsiStr)); // check
end;
procedure TfrxServerSession.MakeServerReply;
var
FStream: TFileStream;
Buffer, sn, s: AnsiString;
i: Integer;
MemStream, MemStreamOut: TMemoryStream;
FSSIStream: TfrxSSIStream;
FTemplate: TfrxServerTemplate;
{$IFDEf Delphi12}
TempStr: AnsiString;
{$ENDIF}
crit: TfrxMutex;
begin
if FData <> nil then
FData.FileName := FName;
if FErrorCode = 200 then
begin
if ClientSocket.Connected or (not FParentReportServer.SocketOpen) then
begin
MemStream := TMemoryStream.Create;
FSSIStream := TfrxSSIStream.Create;
FSSIStream.BasePath := FParentHTTPServer.BasePath;
FSSIStream.Variables := FParentReportServer.Variables;
UpdateLocalVariables;
FSSIStream.LocalVariables := LocalVariables;
try
try
if Length(FReturnData) = 0 then
begin
if FIsReport and (Pos('form', FName) = 0) and ((FFormat = sfHTM) or (FFormat = sfHTMD)) then
begin
WriteHtmlReportIndex(FSSIStream);
end
else
begin
crit := TfrxMutex.Create(FName);
crit.Lock;
FStream := TFileStream.Create(FParentHTTPServer.BasePath + FName, fmOpenRead + fmShareDenyWrite);
try
FSSIStream.CopyFrom(FStream, 0);
finally
FStream.Free;
crit.Unlock;
crit.Free;
end;
if CheckSSI(FName) then
FSSIStream.Prepare
end
end
else
FSSIStream.Write(FReturnData[1], Length(FReturnData)); // check
FSSIStream.Position := 0;
if FGzip and FParentReportServer.SocketOpen then
begin
try
frxCompressStream(FSSIStream, MemStream, gzMax, FName);
except
on E:Exception do
begin
FErrorText := 'GZIP pack error. ' + E.Message;
ErrorLog;
end;
end;
end else
MemStream.CopyFrom(FSSIStream, 0);
MemStream.Position := 0;
sn := 'Content-length';
s := IntToStr(MemStream.Size);
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
if FKeepAlive then
FReplyHeader.Add('Connection: Keep-Alive')
else
FReplyHeader.Add('Connection: Close');
if ServerConfig.GetBool('server.http.mic') then
begin
sn := 'Content-MD5';
s := MD5Stream(MemStream);
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
end;
FReplyHeader.Add('X-Powered-By: FastReportServer/' + SERVER_VERSION);
if ((Pos('sid_', FName) > 0) or (Pos('store_', FName) > 0)) then
begin
s := 'frreport';
FReplyHeader.Add('FastReport-container:' + s);
end;
FReplyHeader.Add('');
Buffer := FReplyHeader.Text;
except
on E:Exception do
begin
FErrorText := 'error prepare output result ' + E.Message;
ErrorLog;
end;
end;
if FParentReportServer.SocketOpen then
begin
MemStreamOut := TMemoryStream.Create;
try
MemStream.SaveToStream(MemStreamOut);
MemStreamOut.Position := 0;
ClientSocket.SendBuf(Buffer[1], Length(Buffer)); // check
ClientSocket.SendStreamThenDrop(MemStreamOut);
except
on E:Exception do
begin
MemStreamOut.Free;
FErrorText := 'error socket stream output result' + E.Message;
ErrorLog;
end;
end;
end else
begin
FData.RepHeader := Buffer;
FData.Stream.CopyFrom(MemStream, 0);
end;
finally
MemStream.Free;
FSSIStream.Free;
end
end;
end else
begin
sn := 'Content-Type';
s := 'text/html';
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
if FErrorCode = 404 then
begin
FTemplate := TfrxServerTemplate.Create;
try
FTemplate.SetTemplate('error404');
FTemplate.Variables.AddVariable('ERROR', FReportMessage + '<br>' + ServerConfig.ServerMessage);
FTemplate.Prepare;
Buffer := FTemplate.TemplateStrings.Text;
finally
FTemplate.Free;
end;
i := Length(Buffer);
FErrorText := FName + ' document not found ' + FReportMessage;
ErrorLog;
end else
if FRedirect or (FErrorCode = 403) then
begin
i := 0;
Buffer := '';
end else
if FErrorCode = 401 then
begin
i := 0;
Buffer := '';
if FAuthInProgress then
FReplyHeader.Add(Format('WWW-Authenticate: ' + FAuthType + ' %s', [FAuthResponse]))
else
begin
if ServerConfig.GetBool('server.security.winauth') then
begin
FReplyHeader.Add('WWW-Authenticate: NTLM');
FReplyHeader.Add('WWW-Authenticate: Negotiate');
FReplyHeader.Add('WWW-Authenticate: Kerberos');
FKeepAlive := True;
end
else
begin
sn := 'WWW-Authenticate';
s := 'Basic realm="' + SERVER_NAME + '"';
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
end;
end;
end else
begin
FTemplate := TfrxServerTemplate.Create;
try
FTemplate.SetTemplate('error500');
FTemplate.Variables.AddVariable('ERROR', '');
FTemplate.Prepare;
Buffer := FTemplate.TemplateStrings.Text;
finally
FTemplate.Free;
end;
i := Length(Buffer);
FErrorText := 'unknown error';
ErrorLog;
end;
if FKeepAlive then
FReplyHeader.Add('Connection: Keep-Alive')
else
FReplyHeader.Add('Connection: Close');
sn := 'Content-length';
s := IntToStr(i);
AddOutData(sn, s);
FReplyHeader.Add(sn + ': ' + s);
FReplyHeader.Add('');
// Buffer := FReplyHeader.Text + Buffer;
if FParentReportServer.SocketOpen then
begin
try
{$IFDEF Delphi12}
TempStr := AnsiString(FReplyHeader.Text);
ClientSocket.SendText(TempStr);
{$ELSE}
ClientSocket.SendText(FReplyHeader.Text);
{$ENDIF}
ClientSocket.SendText(Buffer);
if not FKeepAlive then
ClientSocket.Close;
except
on E: Exception do
begin
FErrorText := 'error socket stream output answer. ' + E.Message;
ErrorLog;
end;
end;
end else
begin
FData.RepHeader := FReplyHeader.Text;
FData.Stream.Write(Buffer[1], Length(Buffer)); // check
end;
end;
end;
procedure TfrxServerSession.ClientExecute;
var
FDSet: TFDSet;
TimeVal: TTimeVal;
TempStream, TempStream1: TMemoryStream;
i: Integer;
Len, HeaderEnd: Integer;
HeaderParsed: Boolean;
function SearchHeaderEnd(Strm: TMemoryStream; StartPos: Integer): Integer;
var
ptrByte: PAnsiChar;
begin
ptrByte := Strm.Memory;
if StartPos < 0 then
StartPos := 0;
Result := -1;
while StartPos < Strm.Size - 3 do
begin
if (ptrByte[StartPos] = #13) and (ptrByte[StartPos + 1] = #10) and (ptrByte[StartPos + 2] = #13) and (ptrByte[StartPos + 3] = #10) then
begin
Result := StartPos;
Break;
end;
Inc(StartPos);
end;
end;
function SearchStringInStream(Strm: TMemoryStream; StartPos: Integer; aString: AnsiString): Integer;
var
ptrByte: PAnsiChar;
i, Reslen: Integer;
begin
Reslen := 0;
ptrByte := Strm.Memory;
if StartPos < 0 then
StartPos := 0;
while StartPos < Strm.Size - 3 do
begin
Reslen := 0;
for i := 1 to Length(aString) do
if (ptrByte[StartPos + i - 1] = aString[i]) then
Inc(Reslen)
else break;
if Reslen = Length(aString) then Break;
Inc(StartPos);
end;
Result := -1;
if Reslen = Length(aString) then
Result := StartPos;
end;
procedure ReadHeader(aHeaderLen: Integer; aStream: TStream);
var
OldPos: Integer;
begin
SetLength(FHeader, aHeaderLen);
try
OldPos := TempStream.Position;
TempStream.Position := 0;
TempStream.ReadBuffer(FHeader[1], aHeaderLen); // check
TempStream.Position := OldPos;
ParseHTTPHeader;
except
on E: Exception do
begin
FErrorText := 'error client stream parsing. ' + E.Message;
ErrorLog;
end;
end;
HeaderParsed := true;
end;
procedure GetDataFromBoundary(sPos: Integer);
var
i: Integer;
ContentDisp, ContentType: AnsiString;
ParamName, lFileName, lHeader: AnsiString;
function GetValue(aStr: AnsiString; aName: AnsiString): AnsiString;
var
i, sPos: Integer;
begin
Result := '';
sPos := Pos(aName + '="', aStr);
if sPos < 1 then Exit;
Inc(sPos, length(aName) + 2);
i := sPos;
while i <= Length(aStr) do
begin
if aStr[i] = '"' then break;
Inc(i);
end;
Result := Copy(aStr, sPos, i - sPos);
end;
begin
sPos := SearchStringInStream(TempStream, sPos, '--' + FBoundary);
if sPos <> -1 then
begin
Inc(sPos, Length(FBoundary) + 2);
i := SearchHeaderEnd(TempStream, sPos);
if i <> -1 then
begin
SetLength(lHeader, i - sPos + 4);
TempStream.Position := sPos;
TempStream.ReadBuffer(lHeader[1], i - sPos + 4);
ContentDisp := ParseHeaderField('Content-Disposition: ', lHeader);
ContentType := ParseHeaderField('Content-Type: ', lHeader);
ParamName := GetValue(ContentDisp, 'name');
if ParamName = '0' then
FFormFileName := ParamName
else
begin
lFileName := ExtractFileName(GetValue(ContentDisp, 'filename'));
SelectFormat(ParamName);
if lFileName <> '' then
FFormFileName := lFileName
end;
//IsFP3Content(ContentType); //not need trash?
sPos := i + 4;
TempStream.Position := sPos;
i := SearchStringInStream(TempStream, sPos, '--' + FBoundary) - 1;
Len := i - 1 - TempStream.Position;
if i <> -1 then
FStream.CopyFrom(TempStream, Len);
end;
end;
if (FContentMD5 <> '') then
begin
FIsFP3 := True;
ParamName := ParseHeaderField('Format-Export: ');
FFormFileName := 'NoInReport.fp3';
SelectFormat(ParamName);
end;
end;
begin
HeaderParsed := False;
LogWriter.StatAddCurrentSession;
FIsExportRedirect := False;
if FParentReportServer.SocketOpen then
begin
FD_ZERO(FDSet);
FD_SET(ClientSocket.SocketHandle, FDSet);
TimeVal.tv_sec := FParentHTTPServer.SocketTimeOut;
TimeVal.tv_usec := 0;
repeat
{$IFDEF CS_ON}
ServCS.Enter;
try
{$ENDIF}
{$IFNDEF Linux}
i := select(0, @FDSet, nil, nil, @TimeVal);
{$ELSE}
i := select(ClientSocket.SocketHandle + 1, @FDSet, nil, nil, @TimeVal);
{$ENDIF}
{$IFDEF CS_ON}
finally
ServCS.Leave;
end;
{$ENDIF}
if i = -1 then
FKeepAlive := False;
if (i > 0) and not Terminated then
begin
TempStream := TMemoryStream.Create;
TempStream1 := TMemoryStream.Create;
HeaderEnd := -1;
Len := 0;
try
i := ClientSocket.ReceiveLength;
try
while (i <> 0) or (FContentLength > TempStream.Size - Len) do
begin
TempStream1.SetSize(i);
ClientSocket.ReceiveBuf(TempStream1.Memory^, i);
i := ClientSocket.ReceiveLength;
TempStream.CopyFrom(TempStream1, 0);
if HeaderEnd = -1 then
HeaderEnd := SearchHeaderEnd(TempStream, TempStream.Size - TempStream1.Size - 4);
if (not HeaderParsed) and (HeaderEnd > 0) then
begin
Len := HeaderEnd + 3;
ReadHeader(Len, TempStream);
end;
if not HeaderParsed and (TempStream.Size > FParentHTTPServer.FMaxHTTPHeaderSize) or
HeaderParsed and (Len > FParentHTTPServer.FMaxHTTPHeaderSize)then
raise Exception.Create('HTTP header is too large.');
if HeaderParsed and (FParentHTTPServer.FMaxContentSize > 0) and
(((FContentLength > 0) and (FContentLength > FParentHTTPServer.FMaxContentSize)) or
(TempStream.Size - Len > FParentHTTPServer.FMaxContentSize)) then
raise Exception.Create('HTTP content size is greater than allowed.');
if (FContentMD5 <> '') and ReportCache.IsReportInCache(FContentMD5, nil, '') then
break;
end;
except
on E: Exception do
begin
FErrorText := 'error socket stream read.' + E.Message;
ErrorLog;
end;
end;
TempStream.Position := 0;
i := StreamSearch(TempStream, 0, #13#10#13#10);
if i <> -1 then
begin
Len := i + 4;
if not HeaderParsed then
ReadHeader(Len, TempStream);
try
if FBoundary <> '' then
GetDataFromBoundary(Len)
else
begin
TempStream.Position := Len;
FStream.CopyFrom(TempStream, TempStream.Size - Len);
end;
except
on E: Exception do
begin
FErrorText := 'error client query.' + E.Message;
ErrorLog;
end;
end;
end;
finally
TempStream.Free;
TempStream1.Free;
end;
end;
{$IFDEF CS_ON}
ServCS.Enter;
try
{$ENDIF}
{$IFNDEF Linux}
i := select(0, nil, @FDSet, nil, @TimeVal);
{$ELSE}
i := select(ClientSocket.SocketHandle + 1, nil, @FDSet, nil, @TimeVal);
{$ENDIF}
{$IFDEF CS_ON}
finally
ServCS.Leave;
end;
{$ENDIF}
if (i > 0) and not Terminated then
if (Length(FHeader) > 0) and ClientSocket.Connected then
begin
ParseParameters;
CreateReplyHTTPData;
MakeServerReply;
end;
until not FKeepAlive;
CloseSession;
end
else
begin
if FData.Stream.Size > 0 then
begin
FStream.CopyFrom(FData.Stream, 0);
FData.Stream.Clear;
end;
FHeader := FData.Header;
ParseHTTPHeader;
ParseParameters;
CreateReplyHTTPData;
MakeServerReply;
FActive := False;
Sleep(100);
end;
LogWriter.StatRemoveCurrentSession;
end;
procedure TfrxServerSession.WriteLogs;
begin
LogWriter.Write(ACCESS_LEVEL, DateTimeToStr(Now) + #9 + SessionId + #9 + FRemoteIP + #9 + FName);
if Length(FReferer) > 0 then
LogWriter.Write(REFERER_LEVEL, DateTimeToStr(Now) + #9 + FRemoteIP + #9 + FReferer);
if Length(FUserAgent) > 0 then
LogWriter.Write(AGENT_LEVEL, DateTimeToStr(Now) + #9 + FRemoteIP + #9 + FUserAgent);
end;
procedure TfrxServerSession.ErrorLog;
begin
LogWriter.Write(ERROR_LEVEL, DateTimeToStr(Now) + #9 + FRemoteIP + #9 + FErrorText);
LogWriter.ErrorReached;
end;
procedure TfrxServerSession.UpdateSessionFName;
begin
SessionManager.FindSessionById(FSessionId).FileName := FName;
end;
procedure TfrxServerSession.CloseSession;
begin
SessionManager.CompleteSessionId(SessionId);
end;
function TfrxServerSession.CheckSSI(FileName: String): Boolean;
var
ext: String;
begin
ext := LowerCase(ExtractFileExt(FileName));
Result := (ext = '.htm') or (ext = '.html') or
(ext = '.shtm') or (ext = '.shtml');
end;
function TfrxServerSession.CheckDeflate(FileName: String): Boolean;
var
ext: String;
begin
ext := LowerCase(ExtractFileExt(FileName));
if Pos('MSIE', FUserAgent) > 0 then
Result := ((ext = '.htm') or (ext = '.html') or
(ext = '.shtm') or (ext = '.shtml') or
(ext = '.css') or (ext = '.txt') or
(ext = '.bmp')) and (FSize > MAX_IE_GZIP)
else
Result := (ext <> '.jpg') and (ext <> '.jpeg') and
(ext <> '.gif') and (ext <> '.png') and
(ext <> '.ods') and (ext <> '.odt') and
(ext <> '.zip') and (ext <> '.rar');
end;
function TfrxServerSession.InitAuth(const SecPackageName: String): boolean;
{$IFNDEF Linux}
var
ntlmSecPI: PSecPkgInfo;
{$ENDIF}
begin
Result := false;
{$IFNDEF Linux}
if QuerySecurityPackageInfo(PChar(SecPackageName),ntlmSecPI) = 0 then
begin
FMaxTokenSize := ntlmSecPI^.cbMaxToken;
FreeContextBuffer(ntlmSecPI);
if AcquireCredentialsHandle(nil, PChar(SecPackageName),
SECPKG_CRED_INBOUND, nil, nil, nil, nil, @FCredHandle, FExpire) = 0 then
Result:=true;
end;
{$ENDIF}
end;
procedure TfrxServerSession.IsFP3Content(aContent: AnsiString);
begin
FIsFP3 := not(Pos('FastReport', FUserAgent) > 0) and
((Pos('application/octet-stream', aContent) > 0) or
(Pos('multipart/form-data; boundary', aContent) > 0) or
(Pos('application/xml', aContent) > 0) or
(Pos('application/zip', aContent) > 0));
FIsFP3 := FIsFP3 or (Pos('application/fp3', aContent) > 0);
end;
procedure TfrxServerSession.FinalAuth;
begin
{$IFNDEF Linux}
FreeCredentialsHandle(@FCredHandle);
{$ENDIF}
end;
function TfrxServerSession.ProcessAuthRequest(AuthRequest: AnsiString; NewConversation: boolean; var AuthResponse: AnsiString;
var ContextHandle: TSecHandle; var AuthFinished: boolean): boolean;
var
InBufD: TSecBufferDesc;
InBuf: TSecBuffer;
OutBufD: TSecBufferDesc;
OutBuf: TSecBuffer;
Attribs: cardinal;
R: integer;
Context: PCtxtHandle;
begin
Result := false;
// prepare input buffer
AuthRequest := Base64Decode(AuthRequest);
inBufD.ulVersion := SECBUFFER_VERSION;
inBufD.cBuffers := 1;
inBufD.pBuffers := @inBuf;
inBuf.BufferType := SECBUFFER_TOKEN;
inBuf.cbBuffer := length(AuthRequest);
inBuf.pvBuffer := AllocMem(inBuf.cbBuffer);
Move(AuthRequest[1], inBuf.pvBuffer^, inBuf.cbBuffer);
// prepare output buffer
outBufD.ulVersion := SECBUFFER_VERSION;
outBufD.cBuffers := 1;
outBufD.pBuffers := @outBuf;
outBuf.BufferType := SECBUFFER_TOKEN;
outBuf.cbBuffer := FMaxTokenSize;
outBuf.pvBuffer := AllocMem(outBuf.cbBuffer);
// process request
if NewConversation then
Context := nil
else
Context := @ContextHandle;
Attribs := 0;
{$IFNDEF Linux}
R := AcceptSecurityContext(@FCredHandle, Context, @inBufD, Attribs, SECURITY_NATIVE_DREP, @ContextHandle,
@outBufD, Attribs, @FExpire);
if (R = SEC_I_COMPLETE_NEEDED) or (R = SEC_I_COMPLETE_AND_CONTINUE) then
if CompleteAuthToken(@ContextHandle, @outBufD) <> 0 then
exit;
{$ENDIF}
AuthFinished := not((R = SEC_I_CONTINUE_NEEDED) or (R = SEC_I_COMPLETE_AND_CONTINUE));
SetLength(AuthResponse, outBuf.cbBuffer);
Move(outBuf.pvBuffer^, AuthResponse[1], outBuf.cbBuffer);
AuthResponse := Base64Encode(AuthResponse);
// free buffers
FreeMem(inBuf.pvBuffer);
FreeMem(outBuf.pvBuffer);
Result := true;
end;
procedure TfrxServerSession.SelectFormat(FormatName: String);
begin
if Length(FormatName) > 0 then
begin
FormatName := UpperCase(FormatName);
if FormatName = 'PDF' then FFormat := sfPDF else
if FormatName = 'ODS' then FFormat := sfODS else
if FormatName = 'ODT' then FFormat := sfODT else
if FormatName = 'XML' then FFormat := sfXML else
if FormatName = 'XLS' then FFormat := sfXLS else
if FormatName = 'RTF' then FFormat := sfRTF else
if FormatName = 'TXT' then FFormat := sfTXT else
if FormatName = 'CSV' then FFormat := sfCSV else
if FormatName = 'JPG' then FFormat := sfJPG else
if FormatName = 'BMP' then FFormat := sfBMP else
if FormatName = 'GIF' then FFormat := sfGIF else
if (FormatName = 'TIFF') or (FormatName = 'TIF') then FFormat := sfTIFF else
if (FormatName = 'FRP') or (FormatName = 'FP3') then FFormat := sfFRP else
if (FormatName = 'HTML') or (FormatName = 'HTM') then FFormat := sfHTM else
FFormat := sfHTMD;
end;
end;
function TfrxServerSession.GetCurrentUserToken: {$IFDEF DEL16ORFPC} THandle {$ELSE} cardinal {$ENDIF};
begin
{$IFNDEF Linux}
if not OpenThreadToken(GetCurrentThread, TOKEN_READ or
TOKEN_DUPLICATE or TOKEN_IMPERSONATE, true, Result) then
if not OpenProcessToken(GetCurrentProcess, TOKEN_READ or
TOKEN_DUPLICATE or TOKEN_IMPERSONATE, Result) then
{$ENDIF}
Result := 0;
end;
procedure TfrxServerSession.CheckAuth;
var
i: Integer;
s: AnsiString;
L, P: AnsiString;
sz: cardinal;
begin
FAuthNeeded := ((Length(ServerConfig.GetValue('server.security.login')) > 0) and
(Length(ServerConfig.GetValue('server.security.password')) > 0))
or (ServerConfig.GetBool('server.security.userauth'));
s := ParseHeaderField('Authorization: ');
if Length(s) > 0 then
begin
FKeepAlive := True;
i := Pos('Basic ', s);
if (i > 0) and not ServerConfig.GetBool('server.security.winauth') then
begin
FKeepAlive := False;
s := Copy(s, i + 6, Length(s) - i - 5);
s := Base64Decode(s);
i := Pos(':', s);
if i > 0 then
begin
L := Copy(s, 1, i - 1);
P := Copy(s, i + 1, Length(s) - i);
FLogin := L;
FPassword := P;
if ServerConfig.GetBool('server.security.userauth') then
begin
FAuthNeeded := not ServerUsers.AllowLogin(L, P);
if FName = '' then
FName := ServerUsers.GetUserIndex(L);
FGroup := ServerUsers.GetGroupOfUser(L);
end
else
if (L = ServerConfig.GetValue('server.security.login')) and
(P = ServerConfig.GetValue('server.security.password')) then
FAuthNeeded := False
end;
end else
begin
// not basic auth
i := Pos(' ', s);
if i = 0 then
i := Length(s);
FAuthType := Copy(s, 1, i - 1);
s := Copy(s, i + 1, Length(s) - i);
if (Pos('Negotiate', FAuthType) > 0 ) or (Pos('Kerberos', FAuthType) > 0) or (Pos('NTLM', FAuthType) > 0 ) and not FAuthFinished then
begin
if FAuthNewConv then
begin
FAuthInProgress := true;
if not InitAuth(FAuthType) then
exit;
end;
if not ProcessAuthRequest(s, FAuthNewConv, FAuthResponse, FContextHandle, FAuthFinished) then
begin
FinalAuth;
exit;
end;
FAuthNewConv := false;
if FAuthFinished then
begin
{$IFNDEF Linux}
if ImpersonateSecurityContext(@FContextHandle) <> 0 then
exit;
sz := 0;
GetUserNameEx(NameSamCompatible, nil, sz);
if sz = 0 then
exit;
SetLength(FLogin, sz);
GetUserNameEx(NameSamCompatible, pointer(FLogin), sz);
FLogin := string(PChar(FLogin));
FPassword := '';
if FToken <> 0 then
CloseHandle(FToken);
FToken := GetCurrentUserToken;
if RevertSecurityContext(@FContextHandle) <> 0 then
exit;
FinalAuth;
{$ENDIF}
FAuthNewConv := True;
FAuthInProgress := False;
FAuthFinished := False;
FAuthNeeded := False;
FKeepAlive := False;
end;
end;
end;
end;
end;
procedure TfrxServerSession.DoGetVariables;
begin
ParentReportServer.OnGetVariables(FName, FVariables, FLogin);
end;
procedure TfrxServerSession.AddOutData(const Name: String; const Value: String);
begin
if FData <> nil then
FData.OutParams.Add(Name + '=' + Value);
end;
procedure TfrxServerSession.UpdateLocalVariables;
var
ReportsListHtml, ReportsListLines: AnsiString;
begin
if ServerConfig.GetBool('server.security.reportslist') then
begin
ReportsListHtml := '';
ReportsListLines := '';
ReportsList.GetReports4Group(FGroup, ReportsListHtml, ReportsListLines);
FLocalVariables.AddVariable('SERVER_REPORTS_LIST', ReportsListLines);
FLocalVariables.AddVariable('SERVER_REPORTS_HTML', ReportsListHtml);
end;
end;
function TfrxServerSession.GetMime(s: String): String;
begin
result := ServerConfig.GetValue('server.exports' + LowerCase(s) + '.mimetype');
if result = '' then
result := GetFileMIMEType(s);
end;
{ TfrxServerData }
procedure TfrxServerData.Assign(Source: TfrxServerData);
begin
FInParams.Assign(Source.InParams);
FOutParams.Assign(Source.FOutParams);
FErrorCode := Source.ErrorCode;
FStream.Clear;
if Source.Stream.Size > 0 then
begin
Source.Stream.Position := 0;
FStream.CopyFrom(Source.Stream, 0);
end;
FErrorCode := Source.ErrorCode;
FFileName := Source.FileName;
end;
constructor TfrxServerData.Create;
begin
FInParams := TStringList.Create;
FOutParams := TStringList.Create;
FStream := TMemoryStream.Create;
FErrorCode := 0;
end;
destructor TfrxServerData.Destroy;
begin
FStream.Free;
FInParams.Free;
FOutParams.Free;
inherited;
end;
{ TfrxServerGuard }
constructor TfrxServerGuard.Create(Server: TfrxReportServer);
begin
inherited Create(True);
FServer := Server;
FTImeOut := ServerConfig.GetNumber('server.http.configrenewtimeout');
if FTimeOut = 0 then
FTimeOut := 30;
FListTimeOut := ServerConfig.GetNumber('server.reports.reportslistrenewtimeout');
if FListTimeOut = 0 then
FListTimeOut := 180;
Priority := tpLowest;
Resume;
end;
destructor TfrxServerGuard.Destroy;
begin
Sleep(100);
inherited;
end;
procedure TfrxServerGuard.DoLoadConf;
begin
FServer.LoadConfigs;
end;
procedure TfrxServerGuard.Execute;
var
time1, time2, out1, out2: Cardinal;
begin
time1 := GetTickCount;
time2 := time1;
out1 := FTimeOut * 1000;
out2 := FListTimeOut * 1000;
while not Terminated do
begin
if (GetTickCount - time1) > out1 then
begin
// Synchronize(DoLoadConf);
DoLoadConf;
time1 := GetTickCount;
end;
if ((GetTickCount - time2) > out2) and ServerConfig.GetBool('server.security.reportslist') then
begin
ReportsList.BuildListOfReports;
time2 := GetTickCount;
end;
Sleep(5000);
PMessages;
end;
end;
initialization
ServCS := TCriticalSection.Create;
{$IFNDEF FPC}
frxDisableThreadSynchronizer := True;
{$ENDIF}
finalization
ServCS.Free;
end.
Reference in New Issue View Git Blame Copy Permalink