mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 15:07:56 +02:00
494 lines
12 KiB
ObjectPascal
494 lines
12 KiB
ObjectPascal
unit httpsearcher;
|
|
|
|
// You can remove the support you do not need.
|
|
{$DEFINE USEFIREBIRD}
|
|
{$DEFINE USESQLITE}
|
|
{$DEFINE USEPOSTGRES}
|
|
{$mode objfpc}{$H+}
|
|
|
|
{$IFDEF USEFIREBIRD}
|
|
{$DEFINE USESQLDB}
|
|
{$ENDIF}
|
|
{$IFDEF USEPOSTGRES}
|
|
{$DEFINE USESQLDB}
|
|
{$ENDIF}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils, DateUtils, sqldb,
|
|
{$IFDEF USESQLDB}
|
|
SQLDBindexDB,
|
|
{$ENDIF}
|
|
{$IFDEF USEFIREBIRD}
|
|
FBindexDB, // Firebird support
|
|
{$ENDIF}
|
|
{$IFDEF USESQLITE}
|
|
sqliteindexdb, // sqlite 3 support
|
|
{$ENDIF}
|
|
{$IFDEF USEPOSTGRES}
|
|
pgindexdb, // Postgres support
|
|
{$ENDIF}
|
|
memindexdb, // Custom Memory file. Always enabled
|
|
fpIndexer, inifiles, httpdefs, fpjson;
|
|
|
|
Type
|
|
{ THTTPSearcher }
|
|
|
|
THTTPSearcher = Class(TComponent)
|
|
private
|
|
FAllowCors: Boolean;
|
|
FDB : TCustomIndexDB;
|
|
FSearch : TFPSearch;
|
|
FDefaultMinRank : Integer;
|
|
FMinRank : Integer;
|
|
FFormattedJSON : Boolean;
|
|
FDefaultMetadata,
|
|
FIncludeMetaData : Boolean;
|
|
FDefaultAvailable : TAvailableMatch;
|
|
FMetadata : TJSONObject;
|
|
FWordsMetadata : TJSONObject;
|
|
procedure ConfigSearch(aRequest: TRequest; aResponse: TResponse);
|
|
procedure ConfigWordList(aRequest: TRequest; out aContaining : UTF8string; Out Partial : TAvailableMatch; Out aSimple : Boolean);
|
|
function SearchDataToJSON(aID: Integer; const aRes: TSearchWordData): TJSONObject;
|
|
procedure SendJSON(J: TJSONObject; aResponse: TResponse);
|
|
procedure SetupMetadata;
|
|
Protected
|
|
function InitSearch(aResponse: TResponse): Boolean;
|
|
function SetupDB(aIni: TCustomIniFile): TCustomIndexDB;
|
|
Property DB : TCustomIndexDB Read FDB;
|
|
Property Search : TFPSearch Read FSearch;
|
|
Property MinRank : Integer Read FMinRank;
|
|
Property FormattedJSON : Boolean Read FFormattedJSON;
|
|
Property AllowCors : Boolean Read FAllowCors;
|
|
Public
|
|
Function CheckParams(aRequest : TRequest; aResponse : TResponse) : Boolean;
|
|
Function CheckSearchParams(aRequest : TRequest; aResponse : TResponse) : Boolean;
|
|
Procedure HTMLSearch(aRequest : TRequest; aResponse : TResponse);
|
|
Procedure WordList(aRequest : TRequest; aResponse : TResponse);
|
|
end;
|
|
|
|
|
|
implementation
|
|
|
|
function THTTPSearcher.SetupDB(aini :TCustomIniFile) : TCustomIndexDB;
|
|
|
|
Const
|
|
SDatabase = 'Database';
|
|
KeyType = 'Type';
|
|
KeyDatabaseName = 'DatabaseName';
|
|
{$IFDEF USESQLDB}
|
|
KeyHostName = 'HostName';
|
|
KeyUser = 'User';
|
|
KeyPassword = 'Password';
|
|
{$ENDIF}
|
|
|
|
{$IFDEF USESQLDB}
|
|
Procedure ConfigSQLDB(DB : TSQLDBIndexDB);
|
|
|
|
begin
|
|
DB.HostName:= aIni.ReadString(SDatabase,KeyHostName,DB.HostName);
|
|
DB.DatabasePath := aIni.ReadString(SDatabase,KeyDatabaseName,DB.DatabasePath);
|
|
DB.UserName := aIni.ReadString(SDatabase,KeyUser,DB.UserName);
|
|
DB.Password := aIni.ReadString(SDatabase,KeyPassword,DB.Password);
|
|
end;
|
|
{$ENDIF USESQLDB}
|
|
|
|
{$IFDEF USESQLLITE}
|
|
Procedure ConfigSQLIte(SDB : TSQLiteIndexDB);
|
|
|
|
begin
|
|
SDB.FileName := aIni.ReadString(SDatabase,KeyDatabaseName,SDB.FileName);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
Procedure ConfigFile(FDB : TFileIndexDB);
|
|
|
|
begin
|
|
FDB.FileName := aIni.ReadString(SDatabase,KeyDatabaseName,FDB.FileName);
|
|
end;
|
|
|
|
Var
|
|
{$IFDEF USESQLDB}
|
|
QDB : TSQLDBIndexDB;
|
|
{$ENDIF}
|
|
{$IFDEF USESQLLITE}
|
|
SDB : TSQLiteIndexDB;
|
|
{$ENDIF}
|
|
MDB : TFileIndexDB;
|
|
aType : String;
|
|
|
|
begin
|
|
Result:=nil;
|
|
aType:=aIni.ReadString(SDatabase,KeyType,'PostGres');
|
|
Case lowercase(aType) of
|
|
{$IFDEF USEPOSTGRES}
|
|
'postgres' :
|
|
begin
|
|
QDB := TPGIndexDB.Create(nil);
|
|
ConfigSQLDB(QDB);
|
|
Result:=QDB;
|
|
end;
|
|
{$ENDIF}
|
|
{$IFDEF USEFIREBIRD}
|
|
'firebird' :
|
|
begin
|
|
QDB := TFBIndexDB.Create(nil);
|
|
ConfigSQLDB(QDB);
|
|
Result:=QDB;
|
|
end;
|
|
{$ENDIF}
|
|
{$IFDEF USESQLITE}
|
|
'sqlite' :
|
|
begin
|
|
SDB := TSQLiteIndexDB.Create(nil);
|
|
ConfigSQLite(SDB);
|
|
Result:=SDB;
|
|
end;
|
|
{$ENDIF}
|
|
'file' :
|
|
begin
|
|
MDB := TFileIndexDB.Create(nil);
|
|
ConfigFile(MDB);
|
|
Result:=MDB;
|
|
end;
|
|
else
|
|
Raise Exception.CreateFmt('Unknown database type: "%s" ',[aType]);
|
|
end;
|
|
end;
|
|
|
|
function THTTPSearcher.CheckParams(aRequest: TRequest; aResponse: TResponse): Boolean;
|
|
|
|
Var
|
|
S : String;
|
|
B : Boolean;
|
|
|
|
begin
|
|
S:=aRequest.QueryFields.Values['q'];
|
|
Result:=S<>'';
|
|
if not Result then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Missing q param';
|
|
aResponse.SendResponse;
|
|
end;
|
|
S:=aRequest.QueryFields.Values['r'];
|
|
Result:=(S='') or (StrToIntDef(S,-1)<>-1);
|
|
if not Result then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Wrong value for r';
|
|
aResponse.SendResponse;
|
|
end;
|
|
S:=aRequest.QueryFields.Values['c'];
|
|
Result:=(S='') or TryStrToBool(S,B);
|
|
if not Result then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Wrong value for c';
|
|
aResponse.SendResponse;
|
|
end;
|
|
S:=aRequest.QueryFields.Values['m'];
|
|
Result:=(S='') or TryStrToBool(S,B);
|
|
if not Result then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Wrong value for m';
|
|
aResponse.SendResponse;
|
|
end;
|
|
end;
|
|
|
|
function THTTPSearcher.CheckSearchParams(aRequest: TRequest; aResponse: TResponse): Boolean;
|
|
|
|
Var
|
|
m,S : String;
|
|
B : Boolean;
|
|
|
|
begin
|
|
S:=aRequest.QueryFields.Values['q'];
|
|
M:=aRequest.QueryFields.Values['t'];
|
|
Result:=(M='');
|
|
if not Result then
|
|
case lowercase(M) of
|
|
'all' :
|
|
if S<>'' then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Q must be empty';
|
|
aResponse.SendResponse;
|
|
end;
|
|
'contains',
|
|
'exact',
|
|
'startswith' :
|
|
if S='' then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Q may not be empty';
|
|
aResponse.SendResponse;
|
|
end;
|
|
else
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Wrong value for t';
|
|
aResponse.SendResponse;
|
|
end;
|
|
S:=aRequest.QueryFields.Values['s'];
|
|
Result:=(S='') or TryStrToBool(S,B);
|
|
if not Result then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Wrong value for s';
|
|
aResponse.SendResponse;
|
|
end;
|
|
if not B then
|
|
begin
|
|
S:=aRequest.QueryFields.Values['m'];
|
|
Result:=(S='') or TryStrToBool(S,B);
|
|
if not Result then
|
|
begin
|
|
aResponse.Code:=400;
|
|
aResponse.CodeText:='Wrong value for m';
|
|
aResponse.SendResponse;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Procedure THTTPSearcher.SetupMetadata;
|
|
|
|
begin
|
|
FMetadata:=TJSONObject.Create([
|
|
'root', 'data',
|
|
'idField','id',
|
|
'fields',TJSONArray.Create([
|
|
TJSONObject.Create(['name','id','type','int']),
|
|
TJSONObject.Create(['name','rank','type','int']),
|
|
TJSONObject.Create(['name','url','type','string','maxlen',100]),
|
|
TJSONObject.Create(['name','context','type','string','maxlen',MaxContextLen]),
|
|
TJSONObject.Create(['name','date','type','date'])
|
|
])
|
|
]);
|
|
FWordsMetadata:=TJSONObject.Create([
|
|
'root', 'data',
|
|
'idField','id',
|
|
'fields',TJSONArray.Create([
|
|
TJSONObject.Create(['name','id','type','int']),
|
|
TJSONObject.Create(['name','word','type','string','maxlen',100])
|
|
])
|
|
]);
|
|
end;
|
|
|
|
Function THTTPSearcher.InitSearch(aResponse : TResponse): Boolean;
|
|
|
|
Const
|
|
BaseName ='docsearch.ini';
|
|
|
|
Function TestCfg(aDir : string) : String;
|
|
|
|
begin
|
|
Result:=aDir+BaseName;
|
|
if not FileExists(Result) then
|
|
Result:='';
|
|
end;
|
|
|
|
Var
|
|
CFN : String;
|
|
aIni: TMemIniFile;
|
|
|
|
begin
|
|
Result:=False;
|
|
if FDB<>Nil then
|
|
exit(True);
|
|
try
|
|
CFN:=TestCfg(GetAppConfigDir(true));
|
|
if (CFN='') then
|
|
CFN:=TestCfg(GetAppConfigDir(False));
|
|
if (CFN='') then
|
|
CFN:=TestCfg('config/');
|
|
if (CFN='') then
|
|
CFN:=TestCfg(ExtractFilePath(ParamStr(0)));
|
|
if (CFN='') then
|
|
CFN:=TestCfg('');
|
|
if (CFN='') then
|
|
Raise Exception.Create('No config file found');
|
|
aIni:=TMemIniFile.Create(CFN);
|
|
try
|
|
FDB:=SetupDB(aIni);
|
|
FFormattedJSON:=aIni.ReadBool('search','formatjson',False);
|
|
FDefaultMinRank:=aIni.ReadInteger('search','minrank',1);
|
|
FDefaultMetadata:=aIni.ReadBool('search','metadata',true);
|
|
FAllowCors:=aIni.ReadBool('search','allowcors',true);
|
|
finally
|
|
aIni.Free;
|
|
end;
|
|
SetupMetadata;
|
|
FSearch:=TFPSearch.Create(Self);
|
|
FSearch.Database:=FDB;
|
|
Result:=True;
|
|
except
|
|
On E : Exception do
|
|
begin
|
|
aResponse.Code:=500;
|
|
aResponse.CodeText:='Could not set up search: '+E.Message;
|
|
aResponse.SendResponse;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Procedure THTTPSearcher.ConfigSearch(aRequest : TRequest; aResponse : TResponse);
|
|
|
|
Var
|
|
S : string;
|
|
O : TSearchOptions;
|
|
B : Boolean;
|
|
|
|
begin
|
|
FMinRank:=StrToIntDef(aRequest.QueryFields.Values['r'],0);
|
|
if FMinRank=0 then
|
|
FMinRank:=FDefaultMinRank;
|
|
S:=aRequest.QueryFields.Values['m'];
|
|
if (S='') or Not TryStrToBool(S,FIncludeMetaData) then
|
|
FIncludeMetaData:=FDefaultMetaData;
|
|
FSearch.SetSearchWord(aRequest.QueryFields.Values['q']);
|
|
O:=[];
|
|
S:=aRequest.QueryFields.Values['c'];
|
|
if (S<>'') and TryStrToBool(S,B) and B then
|
|
Include(O,soContains);
|
|
FSearch.Options:=O;
|
|
end;
|
|
|
|
procedure THTTPSearcher.ConfigWordList(aRequest: TRequest; out aContaining: UTF8string; out Partial: TAvailableMatch; out aSimple: Boolean);
|
|
|
|
Var
|
|
m,S : String;
|
|
|
|
begin
|
|
aContaining:=aRequest.QueryFields.Values['q'];
|
|
M:=aRequest.QueryFields.Values['t'];
|
|
case lowercase(M) of
|
|
'all' : Partial:=amAll;
|
|
'contains' : Partial:=amContains;
|
|
'exact' : Partial:=amExact;
|
|
'startswith' : Partial:=amStartsWith;
|
|
else
|
|
Partial:=FDefaultAvailable;
|
|
if (Partial<>amAll) and (aContaining='') then
|
|
Partial:=amAll;
|
|
end;
|
|
S:=aRequest.QueryFields.Values['s'];
|
|
if (S='') then
|
|
aSimple:=False
|
|
else
|
|
aSimple:=StrToBool(S);
|
|
if ASimple then
|
|
FIncludeMetadata:=False
|
|
else
|
|
begin
|
|
FIncludeMetaData:=FDefaultMetaData;
|
|
S:=aRequest.QueryFields.Values['m'];
|
|
if (S<>'') then
|
|
TryStrToBool(S,FIncludeMetaData);
|
|
end
|
|
end;
|
|
|
|
Function THTTPSearcher.SearchDataToJSON(aID : Integer;const aRes : TSearchWordData) : TJSONObject;
|
|
|
|
begin
|
|
Result:=TJSONObject.Create([
|
|
'id',aID,
|
|
'rank',aRes.Rank,
|
|
'url',aRes.URL,
|
|
'context',ares.Context,
|
|
'date',FormatDateTime('yyyy"-"mm"-"dd"T"hh":"nn":"ss',aRes.FileDate)
|
|
]);
|
|
end;
|
|
|
|
procedure THTTPSearcher.HTMLSearch(aRequest: TRequest; aResponse: TResponse);
|
|
|
|
Var
|
|
I : Integer;
|
|
J : TJSONObject;
|
|
A : TJSONArray;
|
|
|
|
begin
|
|
aResponse.ContentType:='application/json';
|
|
if AllowCORS then
|
|
AResponse.SetCustomHeader('Access-Control-Allow-Origin','*');
|
|
if not CheckParams(aRequest,aResponse) then
|
|
exit;
|
|
if not InitSearch(aResponse) then
|
|
exit;
|
|
ConfigSearch(aRequest,aResponse);
|
|
FSearch.Execute;
|
|
A:=nil;
|
|
J:=TJSONObject.Create;
|
|
try
|
|
if FIncludeMetadata then
|
|
J.Add('metaData',FMetadata.Clone);
|
|
A:=TJSONArray.Create;
|
|
For I:=0 to Search.RankedCount-1 do
|
|
begin
|
|
if Search.RankedResults[I].Rank>=MinRank then
|
|
A.Add(SearchDataToJSON(I+1,Search.RankedResults[I]));
|
|
end;
|
|
J.Add('data',A);
|
|
SendJSON(J,aResponse);
|
|
finally
|
|
J.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure THTTPSearcher.SendJSON(J : TJSONObject; aResponse: TResponse);
|
|
|
|
begin
|
|
if FormattedJSON then
|
|
aResponse.Content:=J.FormatJSON()
|
|
else
|
|
aResponse.Content:=J.AsJSON;
|
|
aResponse.ContentLength:=Length(aResponse.Content);
|
|
aResponse.SendContent;
|
|
end;
|
|
|
|
procedure THTTPSearcher.WordList(aRequest: TRequest; aResponse: TResponse);
|
|
Var
|
|
I : Integer;
|
|
J : TJSONObject;
|
|
A : TJSONArray;
|
|
w,aContaining : UTF8String;
|
|
aPartial : TAvailableMatch;
|
|
aSimple : Boolean;
|
|
aList : TUTF8StringArray;
|
|
|
|
|
|
begin
|
|
aResponse.ContentType:='application/json';
|
|
if AllowCORS then
|
|
AResponse.SetCustomHeader('Access-Control-Allow-Origin','*');
|
|
if not CheckSearchParams(aRequest,aResponse) then
|
|
exit;
|
|
if not InitSearch(aResponse) then
|
|
exit;
|
|
ConfigWordList(aRequest,aContaining,aPartial,aSimple);
|
|
FSearch.GetAvailableWords(aList,aContaining,aPartial);
|
|
J:=TJSONObject.Create;
|
|
try
|
|
if FIncludeMetadata then
|
|
J.Add('metaData',FWordsMetadata.Clone);
|
|
A:=TJSONArray.Create;
|
|
if aSimple then
|
|
For W in aList do
|
|
A.Add(W)
|
|
else
|
|
begin
|
|
For I:=0 to Length(aList)-1 do
|
|
A.Add(TJSONObject.Create(['id',I+1,'word',aList[i]]));
|
|
end;
|
|
J.Add('data',A);
|
|
SendJSON(J,aResponse);
|
|
finally
|
|
J.Free;
|
|
end;
|
|
end;
|
|
|
|
|
|
end.
|
|
|