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.