├── Samples ├── ISAPI │ ├── Readme.txt │ ├── ISAPI.dpr │ └── ISAPI.res ├── CGI │ ├── CGI.dpr │ └── CGI.res ├── FMX │ ├── FMX.res │ ├── Main.pas │ ├── FMX.dpr │ └── Main.fmx ├── VCL │ ├── VCL.res │ ├── Main.pas │ ├── Samples.res │ └── VCL.dpr ├── VCLHorse │ ├── Main.pas │ ├── VCLHorse.res │ ├── VCLHorse.dpr │ └── Main.dfm ├── Console │ ├── Console.dpr │ └── Console.res ├── ClientVCL │ ├── ClientVCL.res │ ├── ClientVCL.dpr │ ├── Main.dfm │ └── Main.pas ├── WindowsService │ ├── Main.pas │ ├── WindowsServer.res │ ├── WindowsService.res │ ├── Main.dfm │ └── WindowsService.dpr ├── DB │ └── FAST_REPORT_EXPORT.FDB ├── WindowsServiceHorse │ ├── Main.pas │ ├── WindowsServiceHorse.res │ ├── Main.dfm │ └── WindowsServiceHorse.dpr ├── ConsoleHorse │ ├── ConsoleHorse.dpr │ └── ConsoleHorse.res ├── Horse │ └── Horse │ │ └── src │ │ ├── Horse.WebModule.lfm │ │ ├── Horse.WebModule.dfm │ │ ├── Horse.Constants.pas │ │ ├── Horse.Proc.pas │ │ ├── Horse.Exception.Interrupted.pas │ │ ├── Horse.Rtti.Helper.pas │ │ ├── Horse.Provider.CGI.pas │ │ ├── Horse.Provider.ISAPI.pas │ │ ├── Horse.Callback.pas │ │ ├── Horse.Rtti.pas │ │ ├── Horse.Provider.Abstract.pas │ │ ├── Horse.Provider.FPC.CGI.pas │ │ ├── Horse.Provider.Apache.pas │ │ ├── Horse.Core.Param.Field.Brackets.pas │ │ ├── Horse.Session.pas │ │ ├── Web.WebConst.pas │ │ ├── ThirdParty.Posix.Syslog.pas │ │ ├── Horse.Core.Param.Header.pas │ │ ├── Horse.Exception.pas │ │ ├── Horse.WebModule.pas │ │ ├── Horse.pas │ │ ├── Horse.Core.Route.Contract.pas │ │ ├── Horse.Provider.IOHandleSSL.pas │ │ ├── Horse.Provider.FPC.Apache.pas │ │ ├── Horse.Core.Group.Contract.pas │ │ ├── Horse.Core.Param.Config.pas │ │ ├── Horse.Provider.FPC.FastCGI.pas │ │ ├── Horse.Provider.FPC.HTTPApplication.pas │ │ ├── Horse.Core.RouterTree.NextCaller.pas │ │ ├── Horse.Provider.FPC.LCL.pas │ │ ├── Horse.Core.Param.pas │ │ ├── Horse.Commons.pas │ │ ├── Horse.Response.pas │ │ ├── Horse.Request.pas │ │ ├── Horse.Provider.FPC.Daemon.pas │ │ ├── Horse.Core.RouterTree.pas │ │ ├── Horse.Core.Route.pas │ │ └── Horse.Provider.VCL.pas ├── Postman │ └── FastReportExport.postman_collection_v2.1.json └── Utils │ ├── Data.pas │ └── Utils.pas ├── Source ├── FRExport.Core.pas ├── FRExport.pas ├── FRExport.Interfaces.pas ├── FRExport.Interfaces.Providers.pas └── FRExport.Types.pas ├── boss-lock.json ├── boss.json ├── .gitignore ├── FastReportExport.groupproj └── README.md /Samples/ISAPI/Readme.txt: -------------------------------------------------------------------------------- 1 | Samples with Horse -------------------------------------------------------------------------------- /Samples/CGI/CGI.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/CGI/CGI.dpr -------------------------------------------------------------------------------- /Samples/CGI/CGI.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/CGI/CGI.res -------------------------------------------------------------------------------- /Samples/FMX/FMX.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/FMX/FMX.res -------------------------------------------------------------------------------- /Samples/VCL/VCL.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/VCL/VCL.res -------------------------------------------------------------------------------- /Samples/FMX/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/FMX/Main.pas -------------------------------------------------------------------------------- /Samples/VCL/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/VCL/Main.pas -------------------------------------------------------------------------------- /Samples/ISAPI/ISAPI.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/ISAPI/ISAPI.dpr -------------------------------------------------------------------------------- /Samples/ISAPI/ISAPI.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/ISAPI/ISAPI.res -------------------------------------------------------------------------------- /Samples/VCL/Samples.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/VCL/Samples.res -------------------------------------------------------------------------------- /Source/FRExport.Core.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Source/FRExport.Core.pas -------------------------------------------------------------------------------- /Samples/VCLHorse/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/VCLHorse/Main.pas -------------------------------------------------------------------------------- /Samples/Console/Console.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/Console/Console.dpr -------------------------------------------------------------------------------- /Samples/Console/Console.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/Console/Console.res -------------------------------------------------------------------------------- /Samples/VCLHorse/VCLHorse.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/VCLHorse/VCLHorse.res -------------------------------------------------------------------------------- /Samples/ClientVCL/ClientVCL.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/ClientVCL/ClientVCL.res -------------------------------------------------------------------------------- /Samples/WindowsService/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/WindowsService/Main.pas -------------------------------------------------------------------------------- /Samples/DB/FAST_REPORT_EXPORT.FDB: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/DB/FAST_REPORT_EXPORT.FDB -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/WindowsServiceHorse/Main.pas -------------------------------------------------------------------------------- /Samples/ConsoleHorse/ConsoleHorse.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/ConsoleHorse/ConsoleHorse.dpr -------------------------------------------------------------------------------- /Samples/ConsoleHorse/ConsoleHorse.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/ConsoleHorse/ConsoleHorse.res -------------------------------------------------------------------------------- /Samples/WindowsService/WindowsServer.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/WindowsService/WindowsServer.res -------------------------------------------------------------------------------- /Samples/WindowsService/WindowsService.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/WindowsService/WindowsService.res -------------------------------------------------------------------------------- /boss-lock.json: -------------------------------------------------------------------------------- 1 | { 2 | "hash": "d41d8cd98f00b204e9800998ecf8427e", 3 | "updated": "2023-05-26T00:37:50.7778974-03:00", 4 | "installedModules": {} 5 | } -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/WindowsServiceHorse.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportExport/HEAD/Samples/WindowsServiceHorse/WindowsServiceHorse.res -------------------------------------------------------------------------------- /Samples/WindowsService/Main.dfm: -------------------------------------------------------------------------------- 1 | object srvFastReport: TsrvFastReport 2 | OldCreateOrder = False 3 | DisplayName = 'Windows Server - Fast Report' 4 | OnStart = ServiceStart 5 | Height = 150 6 | Width = 215 7 | end 8 | -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/Main.dfm: -------------------------------------------------------------------------------- 1 | object srvFastReportHorse: TsrvFastReportHorse 2 | OldCreateOrder = False 3 | DisplayName = 'Windows Server - Fast Report :: Horse' 4 | OnStart = ServiceStart 5 | Height = 150 6 | Width = 215 7 | end 8 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.WebModule.lfm: -------------------------------------------------------------------------------- 1 | object HorseWebModule: THorseWebModule 2 | OldCreateOrder = False 3 | Actions = <> 4 | CreateSession = False 5 | Height = 150 6 | HorizontalOffset = 527 7 | VerticalOffset = 145 8 | Width = 150 9 | end 10 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.WebModule.dfm: -------------------------------------------------------------------------------- 1 | object HorseWebModule: THorseWebModule 2 | OldCreateOrder = False 3 | Actions = < 4 | item 5 | Default = True 6 | Name = 'DefaultHandler' 7 | PathInfo = '/' 8 | OnAction = HandlerAction 9 | end> 10 | Height = 230 11 | Width = 415 12 | end 13 | -------------------------------------------------------------------------------- /boss.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "\u0016\u0016FastReportExport", 3 | "description": "Biblioteca de exportação de relatórios utilizando Fast Report em ambientes multithreading.", 4 | "version": "v1.1.21", 5 | "homepage": "https://github.com/antoniojmsjr/FastReportExport", 6 | "mainsrc": "Source", 7 | "projects": [], 8 | "dependencies": {} 9 | } -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Constants.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Constants; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | const 10 | DEFAULT_HOST = '0.0.0.0'; 11 | DEFAULT_PORT = 9000; 12 | START_RUNNING = 'Server is runing on %s:%d'; 13 | HORSE_VERSION = '3.0.1'; 14 | 15 | implementation 16 | 17 | end. 18 | -------------------------------------------------------------------------------- /Samples/ClientVCL/ClientVCL.dpr: -------------------------------------------------------------------------------- 1 | program ClientVCL; 2 | 3 | uses 4 | Vcl.Forms, 5 | Main in 'Main.pas' {frmMain}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | ReportMemoryLeaksOnShutdown := True; 11 | Application.Initialize; 12 | Application.MainFormOnTaskbar := True; 13 | Application.CreateForm(TfrmMain, frmMain); 14 | Application.Run; 15 | end. 16 | -------------------------------------------------------------------------------- /Samples/FMX/FMX.dpr: -------------------------------------------------------------------------------- 1 | program FMX; 2 | 3 | uses 4 | System.StartUpCopy, 5 | FMX.Forms, 6 | Main in 'Main.pas' {frmMain}, 7 | Utils in '..\Utils\Utils.pas', 8 | Data in '..\Utils\Data.pas'; 9 | 10 | {$R *.res} 11 | 12 | begin 13 | ReportMemoryLeaksOnShutdown := True; 14 | Application.Initialize; 15 | Application.CreateForm(TfrmMain, frmMain); 16 | Application.Run; 17 | end. 18 | -------------------------------------------------------------------------------- /Samples/VCL/VCL.dpr: -------------------------------------------------------------------------------- 1 | program VCL; 2 | 3 | uses 4 | Vcl.Forms, 5 | Main in 'Main.pas' {frmMain}, 6 | Utils in '..\Utils\Utils.pas', 7 | Data in '..\Utils\Data.pas'; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | ReportMemoryLeaksOnShutdown := True; 13 | Application.Initialize; 14 | Application.MainFormOnTaskbar := True; 15 | Application.CreateForm(TfrmMain, frmMain); 16 | Application.Run; 17 | end. 18 | -------------------------------------------------------------------------------- /Samples/VCLHorse/VCLHorse.dpr: -------------------------------------------------------------------------------- 1 | program VCLHorse; 2 | 3 | uses 4 | Vcl.Forms, 5 | Main in 'Main.pas' {frmMain}, 6 | Utils in '..\Utils\Utils.pas', 7 | Data in '..\Utils\Data.pas'; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | ReportMemoryLeaksOnShutdown := True; 13 | Application.Initialize; 14 | Application.MainFormOnTaskbar := True; 15 | Application.CreateForm(TfrmMain, frmMain); 16 | Application.Run; 17 | end. 18 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Proc.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Proc; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | {$IF NOT DEFINED(FPC)} 10 | uses System.SysUtils; 11 | {$ENDIF} 12 | 13 | type 14 | TNextProc = {$IF DEFINED(FPC)}procedure of object{$ELSE}System.SysUtils.TProc{$ENDIF}; 15 | TProc = {$IF DEFINED(FPC)}procedure{$ELSE}System.SysUtils.TProc{$ENDIF}; 16 | 17 | {$IF DEFINED(FPC)} 18 | TProc = procedure(Arg1: T); 19 | {$ENDIF} 20 | 21 | implementation 22 | 23 | end. 24 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Exception.Interrupted.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Exception.Interrupted; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils; 12 | {$ELSE} 13 | System.SysUtils; 14 | {$ENDIF} 15 | 16 | type 17 | EHorseCallbackInterrupted = class(Exception) 18 | constructor Create; reintroduce; 19 | end; 20 | 21 | implementation 22 | 23 | constructor EHorseCallbackInterrupted.Create; 24 | begin 25 | inherited Create(EmptyStr); 26 | end; 27 | 28 | end. 29 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Rtti.Helper.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Rtti.Helper; 2 | 3 | interface 4 | 5 | uses 6 | {$IF DEFINED(FPC)} 7 | RTTI; 8 | {$ELSE} 9 | System.Rtti; 10 | {$ENDIF} 11 | 12 | type 13 | THorseRttiTypeHelper = class helper for TRttiType 14 | public 15 | {$IF NOT DEFINED(FPC)} 16 | function FieldValueAsObject(const AInstance: Pointer; const AFieldName: string): TObject; 17 | {$ENDIF} 18 | end; 19 | 20 | implementation 21 | 22 | {$IF NOT DEFINED(FPC)} 23 | function THorseRttiTypeHelper.FieldValueAsObject(const AInstance: Pointer; const AFieldName: string): TObject; 24 | var 25 | LField: TRttiField; 26 | begin 27 | Result := nil; 28 | LField := GetField(AFieldName); 29 | if Assigned(LField) then 30 | Result := LField.GetValue(AInstance).AsObject; 31 | end; 32 | {$ENDIF} 33 | 34 | end. 35 | -------------------------------------------------------------------------------- /Samples/FMX/Main.fmx: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | Caption = 'Exportar Fast Report' 5 | ClientHeight = 120 6 | ClientWidth = 500 7 | Position = ScreenCenter 8 | FormFactor.Width = 320 9 | FormFactor.Height = 480 10 | FormFactor.Devices = [Desktop] 11 | DesignerMasterStyle = 0 12 | object lytHeader: TLayout 13 | Align = Top 14 | Size.Width = 500.000000000000000000 15 | Size.Height = 50.000000000000000000 16 | Size.PlatformDefault = False 17 | TabOrder = 0 18 | object Button1: TButton 19 | Position.X = 15.000000000000000000 20 | Position.Y = 15.000000000000000000 21 | TabOrder = 1 22 | Text = 'Exportar' 23 | OnClick = Button1Click 24 | end 25 | object Button2: TButton 26 | Position.X = 369.000000000000000000 27 | Position.Y = 15.000000000000000000 28 | Size.Width = 120.000000000000000000 29 | Size.Height = 22.000000000000000000 30 | Size.PlatformDefault = False 31 | TabOrder = 0 32 | Text = 'Exportar - Thread' 33 | OnClick = Button2Click 34 | end 35 | end 36 | end 37 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.CGI.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.CGI; 2 | 3 | interface 4 | 5 | {$IF DEFINED(HORSE_CGI) AND NOT DEFINED(FPC)} 6 | uses Horse.Provider.Abstract, System.SysUtils; 7 | 8 | type 9 | THorseProvider = class(THorseProviderAbstract) 10 | private 11 | class procedure InternalListen; static; 12 | public 13 | class procedure Listen; overload; override; 14 | class procedure Listen(const ACallback: TProc); reintroduce; overload; static; 15 | end; 16 | {$ENDIF} 17 | 18 | implementation 19 | 20 | {$IF DEFINED(HORSE_CGI) AND NOT DEFINED(FPC)} 21 | uses Web.WebBroker, Web.CGIApp, Horse.WebModule; 22 | 23 | class procedure THorseProvider.InternalListen; 24 | begin 25 | Application.Initialize; 26 | Application.WebModuleClass := WebModuleClass; 27 | DoOnListen; 28 | Application.Run; 29 | end; 30 | 31 | class procedure THorseProvider.Listen; 32 | begin 33 | inherited; 34 | InternalListen; 35 | end; 36 | 37 | class procedure THorseProvider.Listen(const ACallback: TProc); 38 | begin 39 | inherited; 40 | SetOnListen(ACallback); 41 | InternalListen; 42 | end; 43 | {$ENDIF} 44 | 45 | end. 46 | -------------------------------------------------------------------------------- /Samples/WindowsService/WindowsService.dpr: -------------------------------------------------------------------------------- 1 | program WindowsService; 2 | 3 | uses 4 | Vcl.SvcMgr, 5 | Main in 'Main.pas' {srvFastReport: TService}, 6 | Utils in '..\Utils\Utils.pas', 7 | Data in '..\Utils\Data.pas'; 8 | 9 | {$R *.RES} 10 | 11 | begin 12 | // Windows 2003 Server requires StartServiceCtrlDispatcher to be 13 | // called before CoRegisterClassObject, which can be called indirectly 14 | // by Application.Initialize. TServiceApplication.DelayInitialize allows 15 | // Application.Initialize to be called from TService.Main (after 16 | // StartServiceCtrlDispatcher has been called). 17 | // 18 | // Delayed initialization of the Application object may affect 19 | // events which then occur prior to initialization, such as 20 | // TService.OnCreate. It is only recommended if the ServiceApplication 21 | // registers a class object with OLE and is intended for use with 22 | // Windows 2003 Server. 23 | // 24 | // Application.DelayInitialize := True; 25 | // 26 | if not Application.DelayInitialize or Application.Installing then 27 | Application.Initialize; 28 | Application.CreateForm(TsrvFastReport, srvFastReport); 29 | Application.Run; 30 | end. 31 | -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/WindowsServiceHorse.dpr: -------------------------------------------------------------------------------- 1 | program WindowsServiceHorse; 2 | 3 | uses 4 | Vcl.SvcMgr, 5 | Main in 'Main.pas' {srvFastReportHorse: TService}, 6 | Utils in '..\Utils\Utils.pas', 7 | Data in '..\Utils\Data.pas'; 8 | 9 | {$R *.RES} 10 | 11 | begin 12 | // Windows 2003 Server requires StartServiceCtrlDispatcher to be 13 | // called before CoRegisterClassObject, which can be called indirectly 14 | // by Application.Initialize. TServiceApplication.DelayInitialize allows 15 | // Application.Initialize to be called from TService.Main (after 16 | // StartServiceCtrlDispatcher has been called). 17 | // 18 | // Delayed initialization of the Application object may affect 19 | // events which then occur prior to initialization, such as 20 | // TService.OnCreate. It is only recommended if the ServiceApplication 21 | // registers a class object with OLE and is intended for use with 22 | // Windows 2003 Server. 23 | // 24 | // Application.DelayInitialize := True; 25 | // 26 | if not Application.DelayInitialize or Application.Installing then 27 | Application.Initialize; 28 | Application.CreateForm(TsrvFastReportHorse, srvFastReportHorse); 29 | Application.Run; 30 | end. 31 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.ISAPI.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.ISAPI; 2 | 3 | interface 4 | 5 | {$IF DEFINED(HORSE_ISAPI) AND NOT DEFINED(FPC)} 6 | uses Horse.Provider.Abstract, System.SysUtils, Web.Win.ISAPIApp; 7 | 8 | type 9 | THorseProvider = class(THorseProviderAbstract) 10 | private 11 | class procedure InternalListen; static; 12 | public 13 | class procedure Listen; overload; override; 14 | class procedure Listen(const ACallback: TProc); reintroduce; overload; static; 15 | end; 16 | {$ENDIF} 17 | 18 | implementation 19 | 20 | {$IF DEFINED(HORSE_ISAPI) AND NOT DEFINED(FPC)} 21 | uses Web.WebBroker, System.Win.ComObj, Winapi.ActiveX, Horse.WebModule; 22 | 23 | exports 24 | GetExtensionVersion, 25 | HttpExtensionProc, 26 | TerminateExtension; 27 | 28 | class procedure THorseProvider.InternalListen; 29 | begin 30 | CoInitFlags := COINIT_MULTITHREADED; 31 | Application.Initialize; 32 | Application.WebModuleClass := WebModuleClass; 33 | DoOnListen; 34 | Application.Run; 35 | end; 36 | 37 | class procedure THorseProvider.Listen; 38 | begin 39 | inherited; 40 | InternalListen; 41 | end; 42 | 43 | class procedure THorseProvider.Listen(const ACallback: TProc); 44 | begin 45 | inherited; 46 | SetOnListen(ACallback); 47 | InternalListen; 48 | end; 49 | {$ENDIF} 50 | 51 | end. 52 | -------------------------------------------------------------------------------- /Samples/VCLHorse/Main.dfm: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | Caption = 'Exportar Fast Report' 5 | ClientHeight = 126 6 | ClientWidth = 244 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | Position = poScreenCenter 15 | OnDestroy = FormDestroy 16 | PixelsPerInch = 96 17 | TextHeight = 13 18 | object Label1: TLabel 19 | Left = 8 20 | Top = 19 21 | Width = 24 22 | Height = 13 23 | Caption = 'Port:' 24 | end 25 | object btnStop: TBitBtn 26 | Left = 104 27 | Top = 50 28 | Width = 90 29 | Height = 25 30 | Caption = 'Stop' 31 | Enabled = False 32 | TabOrder = 0 33 | OnClick = btnStopClick 34 | end 35 | object btnStart: TBitBtn 36 | Left = 8 37 | Top = 50 38 | Width = 90 39 | Height = 25 40 | Caption = 'Start' 41 | TabOrder = 1 42 | OnClick = btnStartClick 43 | end 44 | object edtPort: TEdit 45 | Left = 38 46 | Top = 16 47 | Width = 156 48 | Height = 21 49 | NumbersOnly = True 50 | TabOrder = 2 51 | Text = '9000' 52 | end 53 | object btnBrowser: TButton 54 | Left = 8 55 | Top = 88 56 | Width = 90 57 | Height = 25 58 | Caption = 'Export' 59 | Enabled = False 60 | TabOrder = 3 61 | OnClick = btnBrowserClick 62 | end 63 | end 64 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Callback.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Callback; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | Generics.Collections, fpHTTP, 12 | {$ELSE} 13 | Web.HTTPApp, System.Generics.Collections, 14 | {$ENDIF} 15 | Horse.Request, Horse.Response, Horse.Proc, Horse.Commons; 16 | 17 | type 18 | {$IF DEFINED(FPC)} 19 | THorseCallbackRequest = procedure(AReq: THorseRequest); 20 | THorseCallbackResponse = procedure(ARes: THorseResponse); 21 | THorseCallbackRequestResponse = procedure(AReq: THorseRequest; ARes: THorseResponse); 22 | THorseCallback = procedure(AReq: THorseRequest; ARes: THorseResponse; ANext: TNextProc); 23 | TCallNextPath = function(var APath: TQueue; const AHTTPType: TMethodType; const ARequest: THorseRequest; const AResponse: THorseResponse): Boolean of object; 24 | {$ELSE} 25 | THorseCallbackRequest = reference to procedure(AReq: THorseRequest); 26 | THorseCallbackResponse = reference to procedure(ARes: THorseResponse); 27 | THorseCallbackRequestResponse = reference to procedure(AReq: THorseRequest; ARes: THorseResponse); 28 | THorseCallback = reference to procedure(AReq: THorseRequest; ARes: THorseResponse; ANext: TNextProc); 29 | TCallNextPath = reference to function(var APath: TQueue; const AHTTPType: TMethodType; const ARequest: THorseRequest; const AResponse: THorseResponse): Boolean; 30 | {$ENDIF} 31 | 32 | implementation 33 | 34 | end. 35 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Rtti.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Rtti; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, RTTI, 12 | {$ELSE} 13 | System.SysUtils, System.Rtti, 14 | {$ENDIF} 15 | Horse.Commons; 16 | 17 | type 18 | THorseRtti = class 19 | private 20 | class var FHorseRtti: THorseRtti; 21 | FContext: TRttiContext; 22 | protected 23 | class function GetDefaultHorseRtti: THorseRtti; 24 | public 25 | function GetType(const AClass: TClass): TRttiType; 26 | constructor Create; virtual; 27 | class destructor UnInitialize; {$IFNDEF FPC}virtual;{$ENDIF} 28 | class function GetInstance: THorseRtti; 29 | end; 30 | 31 | implementation 32 | 33 | constructor THorseRtti.Create; 34 | begin 35 | if FHorseRtti <> nil then 36 | raise Exception.Create('The Horse Rtti instance has already been created'); 37 | FContext := TRttiContext.Create; 38 | FHorseRtti := Self; 39 | end; 40 | 41 | class function THorseRtti.GetDefaultHorseRtti: THorseRtti; 42 | begin 43 | if FHorseRtti = nil then 44 | FHorseRtti := THorseRtti.Create; 45 | Result := FHorseRtti; 46 | end; 47 | 48 | class function THorseRtti.GetInstance: THorseRtti; 49 | begin 50 | Result := GetDefaultHorseRtti; 51 | end; 52 | 53 | function THorseRtti.GetType(const AClass: TClass): TRttiType; 54 | begin 55 | Result := FContext.GetType(AClass); 56 | end; 57 | 58 | class destructor THorseRtti.UnInitialize; 59 | begin 60 | if FHorseRtti <> nil then 61 | FreeAndNil(FHorseRtti); 62 | end; 63 | 64 | end. 65 | 66 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Uncomment these types if you want even more clean repository. But be careful. 2 | # It can make harm to an existing project source. Read explanations below. 3 | # 4 | # Resource files are binaries containing manifest, project icon and version info. 5 | # They can not be viewed as text or compared by diff-tools. Consider replacing them with .rc files. 6 | #*.res 7 | # 8 | # Type library file (binary). In old Delphi versions it should be stored. 9 | # Since Delphi 2009 it is produced from .ridl file and can safely be ignored. 10 | #*.tlb 11 | # 12 | # Diagram Portfolio file. Used by the diagram editor up to Delphi 7. 13 | # Uncomment this if you are not using diagrams or use newer Delphi version. 14 | #*.ddp 15 | # 16 | # Visual LiveBindings file. Added in Delphi XE2. 17 | # Uncomment this if you are not using LiveBindings Designer. 18 | #*.vlb 19 | # 20 | # Deployment Manager configuration file for your project. Added in Delphi XE2. 21 | # Uncomment this if it is not mobile development and you do not use remote debug feature. 22 | #*.deployproj 23 | # 24 | # C++ object files produced when C/C++ Output file generation is configured. 25 | # Uncomment this if you are not using external objects (zlib library for example). 26 | #*.obj 27 | # 28 | 29 | # Delphi compiler-generated binaries (safe to delete) 30 | *.exe 31 | *.dll 32 | *.bpl 33 | *.bpi 34 | *.dcp 35 | *.so 36 | *.apk 37 | *.drc 38 | *.map 39 | *.dres 40 | *.rsm 41 | *.tds 42 | *.dcu 43 | *.lib 44 | *.a 45 | *.o 46 | *.ocx 47 | 48 | # Delphi autogenerated files (duplicated info) 49 | *.cfg 50 | *.hpp 51 | *Resource.rc 52 | 53 | # Delphi local files (user-specific info) 54 | *.local 55 | *.identcache 56 | *.projdata 57 | *.tvsconfig 58 | *.dsk 59 | 60 | # Delphi history and backups 61 | __history/ 62 | __recovery/ 63 | *.~* 64 | 65 | # Castalia statistics file (since XE7 Castalia is distributed with Delphi) 66 | *.stat 67 | 68 | # Boss dependency manager vendor folder https://github.com/HashLoad/boss 69 | modules/ 70 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.Abstract.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.Abstract; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Horse.Proc, 12 | {$ELSE} 13 | System.SysUtils, 14 | {$ENDIF} 15 | Horse.Core; 16 | 17 | type 18 | THorseProviderAbstract = class(THorseCore) 19 | private 20 | class var FOnListen: TProc; 21 | class var FOnStopListen: TProc; 22 | class function GetOnStopListen: TProc; static; 23 | protected 24 | class function GetOnListen: TProc; static; 25 | class procedure SetOnListen(const AValue: TProc); static; 26 | class procedure SetOnStopListen(const AValue: TProc); static; 27 | class procedure DoOnListen; 28 | class procedure DoOnStopListen; 29 | public 30 | class property OnListen: TProc read GetOnListen write SetOnListen; 31 | class property OnStopListen: TProc read GetOnStopListen write SetOnStopListen; 32 | class procedure Listen; virtual; abstract; 33 | class procedure StopListen; virtual; 34 | end; 35 | 36 | implementation 37 | 38 | class procedure THorseProviderAbstract.DoOnListen; 39 | begin 40 | if Assigned(FOnListen) then 41 | FOnListen({$IF DEFINED(FPC)}T(GetInstance){$ELSE}GetInstance{$ENDIF}); 42 | end; 43 | 44 | class procedure THorseProviderAbstract.DoOnStopListen; 45 | begin 46 | if Assigned(FOnStopListen) then 47 | FOnStopListen({$IF DEFINED(FPC)}T(GetInstance){$ELSE}GetInstance{$ENDIF}); 48 | end; 49 | 50 | class function THorseProviderAbstract.GetOnListen: TProc; 51 | begin 52 | Result := FOnListen; 53 | end; 54 | 55 | class function THorseProviderAbstract.GetOnStopListen: TProc; 56 | begin 57 | Result := FOnStopListen; 58 | end; 59 | 60 | class procedure THorseProviderAbstract.SetOnListen(const AValue: TProc); 61 | begin 62 | FOnListen := AValue; 63 | end; 64 | 65 | class procedure THorseProviderAbstract.SetOnStopListen(const AValue: TProc); 66 | begin 67 | FOnStopListen := AValue; 68 | end; 69 | 70 | class procedure THorseProviderAbstract.StopListen; 71 | begin 72 | raise Exception.Create('StopListen not implemented'); 73 | end; 74 | 75 | end. 76 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.FPC.CGI.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.FPC.CGI; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | {$IF DEFINED(HORSE_CGI) AND DEFINED(FPC)} 10 | uses SysUtils, Classes, fpCGI, fphttp, httpdefs, Horse.Provider.Abstract, Horse.Proc; 11 | 12 | type 13 | THorseProvider = class(THorseProviderAbstract) 14 | private 15 | class var FCGIApplication: TCGIApplication; 16 | class function GetDefaultCGIApplication: TCGIApplication; 17 | class function CGIApplicationIsNil: Boolean; 18 | class procedure InternalListen; virtual; 19 | class procedure DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 20 | public 21 | constructor Create; reintroduce; overload; 22 | class procedure Listen; overload; override; 23 | class procedure Listen(const ACallback: TProc); reintroduce; overload; static; 24 | end; 25 | 26 | var 27 | ShowCleanUpErrors: Boolean = False; 28 | {$ENDIF} 29 | 30 | implementation 31 | 32 | {$IF DEFINED(HORSE_CGI) AND DEFINED(FPC)} 33 | uses Horse.WebModule; 34 | 35 | class function THorseProvider.GetDefaultCGIApplication: TCGIApplication; 36 | begin 37 | if CGIApplicationIsNil then 38 | FCGIApplication := Application; 39 | Result := FCGIApplication; 40 | end; 41 | 42 | class function THorseProvider.CGIApplicationIsNil: Boolean; 43 | begin 44 | Result := FCGIApplication = nil; 45 | end; 46 | 47 | constructor THorseProvider.Create; 48 | begin 49 | inherited Create; 50 | end; 51 | 52 | class procedure THorseProvider.InternalListen; 53 | var 54 | LCGIApplication: TCGIApplication; 55 | begin 56 | inherited; 57 | LCGIApplication := GetDefaultCGIApplication; 58 | LCGIApplication.AllowDefaultModule := True; 59 | LCGIApplication.OnGetModule := DoGetModule; 60 | LCGIApplication.LegacyRouting := True; 61 | LCGIApplication.Initialize; 62 | DoOnListen; 63 | LCGIApplication.Run; 64 | end; 65 | 66 | class procedure THorseProvider.DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 67 | begin 68 | ModuleClass := THorseWebModule; 69 | end; 70 | 71 | class procedure THorseProvider.Listen; 72 | begin 73 | InternalListen;; 74 | end; 75 | 76 | class procedure THorseProvider.Listen(const ACallback: TProc); 77 | begin 78 | SetOnListen(ACallback); 79 | InternalListen; 80 | end; 81 | {$ENDIF} 82 | 83 | end. 84 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.Apache.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.Apache; 2 | 3 | interface 4 | 5 | {$IF DEFINED(HORSE_APACHE) AND NOT DEFINED(FPC)} 6 | uses Horse.Provider.Abstract, System.SysUtils, Web.HTTPD24Impl; 7 | 8 | type 9 | THorseProvider = class(THorseProviderAbstract) 10 | private 11 | class var FHandlerName: string; 12 | class var FDefaultModule: Pointer; 13 | class procedure InternalListen; static; 14 | class procedure SetHandlerName(const AValue: string); static; 15 | class function GetHandlerName: string; static; 16 | class function GetDefaultModule: Pointer; static; 17 | class procedure SetDefaultModule(const AValue: Pointer); static; 18 | public 19 | class property HandlerName: string read GetHandlerName write SetHandlerName; 20 | class property DefaultModule: Pointer read GetDefaultModule write SetDefaultModule; 21 | class procedure Listen; overload; override; 22 | class procedure Listen(const ACallback: TProc); reintroduce; overload; static; 23 | end; 24 | {$ENDIF} 25 | 26 | implementation 27 | 28 | {$IF DEFINED(HORSE_APACHE) AND NOT DEFINED(FPC)} 29 | uses 30 | Web.WebBroker, Web.ApacheApp, 31 | {$IFDEF MSWINDOWS} 32 | Winapi.ActiveX, System.Win.ComObj, 33 | {$ENDIF} 34 | Horse.WebModule; 35 | 36 | class procedure THorseProvider.InternalListen; 37 | begin 38 | {$IFDEF MSWINDOWS} 39 | CoInitFlags := COINIT_MULTITHREADED; 40 | {$ENDIF} 41 | Web.ApacheApp.InitApplication(FDefaultModule, UTF8String(FHandlerName)); 42 | Application.Initialize; 43 | Application.WebModuleClass := WebModuleClass; 44 | DoOnListen; 45 | Application.Run; 46 | end; 47 | 48 | class procedure THorseProvider.Listen; 49 | begin 50 | inherited; 51 | InternalListen; 52 | end; 53 | 54 | class procedure THorseProvider.Listen(const ACallback: TProc); 55 | begin 56 | inherited; 57 | SetOnListen(ACallback); 58 | InternalListen; 59 | end; 60 | 61 | class function THorseProvider.GetHandlerName: string; 62 | begin 63 | Result := FHandlerName; 64 | end; 65 | 66 | class procedure THorseProvider.SetHandlerName(const AValue: string); 67 | begin 68 | FHandlerName := AValue; 69 | end; 70 | 71 | class function THorseProvider.GetDefaultModule: Pointer; 72 | begin 73 | Result := FDefaultModule; 74 | end; 75 | 76 | class procedure THorseProvider.SetDefaultModule(const AValue: Pointer); 77 | begin 78 | FDefaultModule := AValue; 79 | end; 80 | {$ENDIF} 81 | 82 | end. 83 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.Param.Field.Brackets.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.Param.Field.Brackets; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Classes, 12 | {$ELSE} 13 | System.SysUtils, System.Classes, 14 | {$ENDIF} 15 | Horse.Commons; 16 | 17 | type 18 | THorseCoreParamFieldLhsBrackets = class 19 | private 20 | FEq: string; 21 | FNe: string; 22 | FLt: string; 23 | FLte: string; 24 | FGt: string; 25 | FGte: string; 26 | FRange: string; 27 | FLike: string; 28 | FTypes: TLhsBrackets; 29 | public 30 | property Eq: string read Feq; 31 | property Ne: string read Fne; 32 | property Lt: string read Flt; 33 | property Lte: string read Flte; 34 | property Gt: string read Fgt; 35 | property Gte: string read Fgte; 36 | property Range: string read Frange; 37 | property Like: string read Flike; 38 | property Types: TLhsBrackets read FTypes write FTypes; 39 | procedure SetValue(const AType: TLhsBracketsType; const AValue: string); 40 | function GetValue(const AType: TLhsBracketsType): string; 41 | end; 42 | 43 | implementation 44 | 45 | procedure THorseCoreParamFieldLhsBrackets.SetValue(const AType: TLhsBracketsType; const AValue: string); 46 | begin 47 | case AType of 48 | TLhsBracketsType.Equal: 49 | FEq := AValue; 50 | TLhsBracketsType.NotEqual: 51 | FNe := AValue; 52 | TLhsBracketsType.LessThan: 53 | FLt := AValue; 54 | TLhsBracketsType.LessThanOrEqual: 55 | FLte := AValue; 56 | TLhsBracketsType.GreaterThan: 57 | FGt := AValue; 58 | TLhsBracketsType.GreaterThanOrEqual: 59 | FGte := AValue; 60 | TLhsBracketsType.Range: 61 | FRange := AValue; 62 | TLhsBracketsType.Like: 63 | FLike := AValue; 64 | end; 65 | end; 66 | 67 | function THorseCoreParamFieldLhsBrackets.GetValue(const AType: TLhsBracketsType): string; 68 | begin 69 | case AType of 70 | TLhsBracketsType.Equal: 71 | Result := FEq; 72 | TLhsBracketsType.NotEqual: 73 | Result := FNe; 74 | TLhsBracketsType.LessThan: 75 | Result := FLt; 76 | TLhsBracketsType.LessThanOrEqual: 77 | Result := FLte; 78 | TLhsBracketsType.GreaterThan: 79 | Result := FGt; 80 | TLhsBracketsType.GreaterThanOrEqual: 81 | Result := FGte; 82 | TLhsBracketsType.Range: 83 | Result := FRange; 84 | TLhsBracketsType.Like: 85 | Result := FLike; 86 | end; 87 | end; 88 | 89 | end. 90 | 91 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Session.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Session; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Generics.Collections; 12 | {$ELSE} 13 | System.SysUtils, System.Generics.Collections; 14 | {$ENDIF} 15 | 16 | type 17 | TSession = class 18 | end; 19 | 20 | TSessionClass = class of TSession; 21 | 22 | THorseSessions = class 23 | private 24 | FSessions: TObjectDictionary; 25 | function GetSession(const ASessionClass: TSessionClass): TSession; overload; 26 | function GetObject(const ASessionClass: TSessionClass): TObject; overload; 27 | public 28 | function TryGetSession(out ASession: T): Boolean; 29 | function Contains(const ASessionClass: TSessionClass): Boolean; 30 | function SetSession(const ASessionClass: TSessionClass; const AInstance: TSession): THorseSessions; 31 | property Session[const ASessionClass: TSessionClass]: TSession read GetSession; 32 | property &Object[const ASessionClass: TSessionClass]: TObject read GetObject; 33 | constructor Create; 34 | destructor Destroy; override; 35 | end; 36 | 37 | implementation 38 | 39 | constructor THorseSessions.Create; 40 | begin 41 | FSessions := TObjectDictionary.Create([doOwnsValues]); 42 | end; 43 | 44 | destructor THorseSessions.Destroy; 45 | begin 46 | FSessions.Free; 47 | inherited Destroy; 48 | end; 49 | 50 | function THorseSessions.GetObject(const ASessionClass: TSessionClass): TObject; 51 | begin 52 | Result := FSessions.Items[ASessionClass]; 53 | end; 54 | 55 | function THorseSessions.GetSession(const ASessionClass: TSessionClass): TSession; 56 | begin 57 | Result := FSessions.Items[ASessionClass]; 58 | end; 59 | 60 | function THorseSessions.SetSession(const ASessionClass: TSessionClass; const AInstance: TSession): THorseSessions; 61 | begin 62 | Result := Self; 63 | if not ASessionClass.InheritsFrom(AInstance.ClassType) then 64 | raise Exception.CreateFmt('SessionClass differs from of instance[%s].', [AInstance.ClassType.ClassName]); 65 | FSessions.AddOrSetValue(ASessionClass, AInstance); 66 | end; 67 | 68 | function THorseSessions.Contains(const ASessionClass: TSessionClass): Boolean; 69 | begin 70 | Result := FSessions.ContainsKey(ASessionClass); 71 | end; 72 | 73 | function THorseSessions.TryGetSession(out ASession: T): Boolean; 74 | begin 75 | Result := FSessions.TryGetValue(TSessionClass(T), TSession(ASession)); 76 | end; 77 | 78 | end. 79 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Web.WebConst.pas: -------------------------------------------------------------------------------- 1 | unit Web.WebConst; 2 | 3 | interface 4 | 5 | resourcestring 6 | sDuplicateActionName = 'Duplicate action name'; 7 | sOnlyOneDispatcher = 'Only one WebDispatcher per form/data module'; 8 | sHTTPItemName = 'Name'; 9 | sHTTPItemURI = 'PathInfo'; 10 | sHTTPItemEnabled = 'Enabled'; 11 | sHTTPItemDefault = 'Default'; 12 | sHTTPItemProducer = 'Producer'; 13 | sHTTPItemMethod = 'Method'; 14 | 15 | sResNotFound = 'Resource %s not found'; 16 | 17 | sTooManyColumns = 'Too many table columns'; 18 | sFieldNameColumn = 'Field Name'; 19 | sFieldTypeColumn = 'Field Type'; 20 | 21 | sInternalApplicationError = 22 | '' + 23 | '' + 24 | ' ' + 25 | ' ' + 26 | ' Error 500: Internal Server Error' + 27 | '' + 28 | '' + 30 | '
' + 31 | '

5🔥🙀

' + 32 | '

🐎 Internal Server Error 🐎

%0:s

' 33 | + 34 | '

%1:s

' + 35 | '
' + 36 | '' + 37 | ''; 38 | 39 | sWebFileExtensionItemExtensions = 'Extensions'; 40 | sWebFileExtensionItemMimeType = 'Mime Type'; 41 | sDuplicateMimeTypes = 'Duplicate mime types for extension: %s'; 42 | sWebFileDirectoryItemMask = 'Directory Mask'; 43 | sWebFileDirectoryItemAction = 'Action'; 44 | sWebFileExtensionsItemDisplayName = 'Mime type: ''%0:s'', Extensions: ''%1:s'''; 45 | sWebDirectoryInclude = 'Include'; 46 | sWebDirectoryExclude = 'Exclude'; 47 | sWebDirectoryItemDisplayName = 'Action: %0:s, Mask: ''%1:s'''; 48 | 49 | {$IF (DEFINED(FPC) OR (CompilerVersion > 27.0))} 50 | sErrorDecodingURLText = 'Error decoding URL text'; 51 | sInvalidURLEncodedChar = 'Invalid URL encoded char'; 52 | sInvalidHTMLEncodedChar = 'Invalid HTML encoded char'; 53 | sFactoryAlreadyRegistered = 'Factory already registered'; 54 | sAppFactoryAlreadyRegistered = 'App factory already registered'; 55 | {$IFEND} 56 | 57 | implementation 58 | 59 | end. 60 | -------------------------------------------------------------------------------- /Samples/ClientVCL/Main.dfm: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | ActiveControl = btnRequest 5 | Caption = 'Client request Fast Report Export' 6 | ClientHeight = 361 7 | ClientWidth = 459 8 | Color = clBtnFace 9 | Constraints.MinHeight = 400 10 | Constraints.MinWidth = 475 11 | Font.Charset = DEFAULT_CHARSET 12 | Font.Color = clWindowText 13 | Font.Height = -11 14 | Font.Name = 'Tahoma' 15 | Font.Style = [] 16 | OldCreateOrder = False 17 | Position = poScreenCenter 18 | PixelsPerInch = 96 19 | TextHeight = 13 20 | object Bevel1: TBevel 21 | Left = 0 22 | Top = 60 23 | Width = 459 24 | Height = 5 25 | Align = alTop 26 | Shape = bsTopLine 27 | ExplicitWidth = 531 28 | end 29 | object pnlHeader: TPanel 30 | Left = 0 31 | Top = 0 32 | Width = 459 33 | Height = 60 34 | Align = alTop 35 | BevelOuter = bvNone 36 | Caption = 'pnlHeader' 37 | ShowCaption = False 38 | TabOrder = 0 39 | object lblURLTitle: TLabel 40 | Left = 10 41 | Top = 10 42 | Width = 19 43 | Height = 13 44 | Caption = 'URL' 45 | end 46 | object edtURL: TEdit 47 | Left = 10 48 | Top = 29 49 | Width = 300 50 | Height = 21 51 | TabOrder = 0 52 | Text = 'http://localhost:9000/export/43' 53 | end 54 | object btnRequest: TButton 55 | Left = 322 56 | Top = 27 57 | Width = 130 58 | Height = 25 59 | Caption = 'Request' 60 | TabOrder = 1 61 | OnClick = btnRequestClick 62 | end 63 | end 64 | object vledtResponseHeaders: TValueListEditor 65 | Left = 0 66 | Top = 65 67 | Width = 459 68 | Height = 266 69 | Align = alClient 70 | BorderStyle = bsNone 71 | KeyOptions = [keyEdit] 72 | Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goColSizing, goEditing, goRowSelect, goThumbTracking] 73 | ScrollBars = ssVertical 74 | TabOrder = 1 75 | ExplicitHeight = 366 76 | ColWidths = ( 77 | 197 78 | 260) 79 | end 80 | object btnOpenFile: TButton 81 | Left = 0 82 | Top = 331 83 | Width = 459 84 | Height = 30 85 | Align = alBottom 86 | Caption = 'Open File' 87 | TabOrder = 2 88 | OnClick = btnOpenFileClick 89 | ExplicitTop = 431 90 | end 91 | object NetHTTPClient: TNetHTTPClient 92 | Asynchronous = False 93 | ConnectionTimeout = 60000 94 | ResponseTimeout = 60000 95 | HandleRedirects = True 96 | AllowCookies = True 97 | UserAgent = 'Embarcadero URI Client/1.0' 98 | Left = 144 99 | end 100 | object NetHTTPRequest: TNetHTTPRequest 101 | Asynchronous = False 102 | ConnectionTimeout = 60000 103 | ResponseTimeout = 60000 104 | Client = NetHTTPClient 105 | Left = 208 106 | end 107 | end 108 | -------------------------------------------------------------------------------- /Samples/ClientVCL/Main.pas: -------------------------------------------------------------------------------- 1 | unit Main; 2 | 3 | interface 4 | 5 | uses 6 | Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, 7 | Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, 8 | System.Net.URLClient, System.Net.HttpClient, System.Net.HttpClientComponent, 9 | Vcl.Grids, Vcl.ValEdit; 10 | 11 | type 12 | TfrmMain = class(TForm) 13 | pnlHeader: TPanel; 14 | edtURL: TEdit; 15 | lblURLTitle: TLabel; 16 | NetHTTPClient: TNetHTTPClient; 17 | NetHTTPRequest: TNetHTTPRequest; 18 | Bevel1: TBevel; 19 | btnRequest: TButton; 20 | vledtResponseHeaders: TValueListEditor; 21 | btnOpenFile: TButton; 22 | procedure btnRequestClick(Sender: TObject); 23 | procedure btnOpenFileClick(Sender: TObject); 24 | private 25 | { Private declarations } 26 | FPDFFile: string; 27 | public 28 | { Public declarations } 29 | end; 30 | 31 | var 32 | frmMain: TfrmMain; 33 | 34 | implementation 35 | 36 | {$R *.dfm} 37 | 38 | uses 39 | System.IOUtils, Winapi.ShellAPI; 40 | 41 | procedure OpenPDF(const pFile: TFileName; const pTypeForm: Integer = SW_NORMAL); 42 | var 43 | lPdir: PChar; 44 | begin 45 | GetMem(lPdir, 256); 46 | StrPCopy(lPdir, pFile); 47 | ShellExecute(0, nil, Pchar(pFile), nil, lPdir, pTypeForm); 48 | FreeMem(lPdir, 256); 49 | end; 50 | 51 | procedure TfrmMain.btnOpenFileClick(Sender: TObject); 52 | begin 53 | OpenPDF(FPDFFile); 54 | end; 55 | 56 | procedure TfrmMain.btnRequestClick(Sender: TObject); 57 | var 58 | lHTTPResponse: IHTTPResponse; 59 | lPDFStrem: TFileStream; 60 | lHeaderValue: TNameValuePair; 61 | lContentDisposition: string; 62 | begin 63 | vledtResponseHeaders.Strings.Clear; 64 | 65 | lHTTPResponse := NetHTTPRequest.Client.Get(edtURL.Text); 66 | 67 | if (lHTTPResponse.StatusCode <> 200) then 68 | raise Exception.CreateFmt('%d - %s', [lHTTPResponse.StatusCode, lHTTPResponse.StatusText]); 69 | 70 | lHTTPResponse.ContentStream.Position := 0; 71 | if not Assigned(lHTTPResponse.ContentStream) then 72 | raise Exception.Create('Content response empty.'); 73 | 74 | lContentDisposition := lHTTPResponse.HeaderValue['Content-Disposition']; 75 | lContentDisposition := StringReplace(lContentDisposition, '"', '', [rfReplaceAll]); 76 | FPDFFile := Trim(Copy(lContentDisposition, Pos('=', lContentDisposition)+1, Length(lContentDisposition))); 77 | 78 | if (FPDFFile = EmptyStr) then 79 | FPDFFile := ExtractFilePath(ParamStr(0)) + 'FastReportExport.pdf' 80 | else 81 | FPDFFile := ExtractFilePath(ParamStr(0)) + FPDFFile; 82 | 83 | lPDFStrem := TFileStream.Create(FPDFFile, fmCreate); 84 | try 85 | lPDFStrem.CopyFrom(lHTTPResponse.ContentStream, 0); 86 | finally 87 | lPDFStrem.Free; 88 | end; 89 | 90 | for lHeaderValue in lHTTPResponse.Headers do 91 | vledtResponseHeaders.InsertRow(lHeaderValue.Name, lHeaderValue.Value, True); 92 | vledtResponseHeaders.Refresh; 93 | 94 | if FileExists(FPDFFile) then 95 | ShowMessage(FPDFFile); 96 | end; 97 | 98 | end. 99 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/ThirdParty.Posix.Syslog.pas: -------------------------------------------------------------------------------- 1 | { ****************************************************************************** } 2 | { } 3 | { Linux Daemon with Delphi } 4 | { } 5 | { Author: Paolo Rossi (2017) } 6 | { } 7 | { http://www.paolorossi.net } 8 | { http://blog.paolorossi.net } 9 | { https://github.com/paolo-rossi } 10 | { } 11 | { ****************************************************************************** } 12 | unit ThirdParty.Posix.Syslog; 13 | 14 | interface 15 | 16 | {$IFDEF POSIX} 17 | 18 | uses 19 | System.SysUtils, 20 | Posix.Base; 21 | 22 | const // openlog() option 23 | LOG_PID = $01; 24 | LOG_CONS = $02; 25 | LOG_ODELAY = $04; 26 | LOG_NDELAY = $08; 27 | LOG_NOWAIT = $10; 28 | LOG_PERROR = $20; 29 | 30 | const // openlog() facility 31 | LOG_KERN = 0 shl 3; 32 | LOG_USER = 1 shl 3; 33 | LOG_MAIL = 2 shl 3; 34 | LOG_DAEMON = 3 shl 3; 35 | LOG_AUTH = 4 shl 3; 36 | LOG_SYSLOG = 5 shl 3; 37 | LOG_LPR = 6 shl 3; 38 | LOG_NEWS = 7 shl 3; 39 | LOG_UUCP = 8 shl 3; 40 | LOG_CRON = 9 shl 3; 41 | LOG_AUTHPRIV = 10 shl 3; 42 | LOG_FTP = 11 shl 3; 43 | LOG_LOCAL0 = 16 shl 3; 44 | LOG_LOCAL1 = 17 shl 3; 45 | LOG_LOCAL2 = 18 shl 3; 46 | LOG_LOCAL3 = 19 shl 3; 47 | LOG_LOCAL4 = 20 shl 3; 48 | LOG_LOCAL5 = 21 shl 3; 49 | LOG_LOCAL6 = 22 shl 3; 50 | LOG_LOCAL7 = 23 shl 3; 51 | LOG_NFACILITIES = 24; 52 | LOG_FACMASK = $03F8; 53 | INTERNAL_NOPRI = $10; 54 | INTERNAL_MARK = LOG_NFACILITIES shl 3; 55 | 56 | const // setlogmask() level 57 | LOG_EMERG = 0; 58 | LOG_ALERT = 1; 59 | LOG_CRIT = 2; 60 | LOG_ERR = 3; 61 | LOG_WARNING = 4; 62 | LOG_NOTICE = 5; 63 | LOG_INFO = 6; 64 | LOG_DEBUG = 7; 65 | LOG_PRIMASK = $07; 66 | 67 | procedure closelog; cdecl; 68 | external libc name _PU + 'closelog'; 69 | 70 | procedure openlog(ident: MarshaledAString; option: LongInt; facility: LongInt); cdecl; 71 | external libc name _PU + 'openlog'; 72 | 73 | function setlogmask(mask: LongInt): LongInt; cdecl; 74 | external libc name _PU + 'setlogmask'; 75 | 76 | procedure _syslog(priority: LongInt; _format: MarshaledAString; args: array of const); cdecl; 77 | external libc name _PU + 'syslog'; 78 | 79 | // procedure openlog2(ident: MarshaledAString; option: LongInt; facility: LongInt); cdecl; 80 | 81 | procedure Syslog(APriority: LongInt; const AFormat: string); overload; 82 | 83 | procedure Syslog(APriority: LongInt; const AFormat: string; AArgs: array of const); overload; 84 | 85 | {$ENDIF} 86 | 87 | implementation 88 | 89 | {$IFDEF POSIX} 90 | 91 | procedure Syslog(APriority: LongInt; const AFormat: string); 92 | var 93 | LMarshaller: TMarshaller; 94 | str: MarshaledAString; 95 | begin 96 | str := LMarshaller.AsAnsi(AFormat, CP_UTF8).ToPointer; 97 | _syslog(APriority, str, []); 98 | end; 99 | 100 | procedure Syslog(APriority: LongInt; const AFormat: string; AArgs: array of const); 101 | begin 102 | Syslog(APriority, Format(AFormat, AArgs)); 103 | end; 104 | 105 | {$ENDIF} 106 | 107 | end. 108 | -------------------------------------------------------------------------------- /Source/FRExport.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | { } 3 | { FRExport } 4 | { } 5 | { Copyright (C) Antônio José Medeiros Schneider Júnior } 6 | { } 7 | { https://github.com/antoniojmsjr/FastReportExport } 8 | { } 9 | { } 10 | {******************************************************************************} 11 | { } 12 | { Licensed under the Apache License, Version 2.0 (the "License"); } 13 | { you may not use this file except in compliance with the License. } 14 | { You may obtain a copy of the License at } 15 | { } 16 | { http://www.apache.org/licenses/LICENSE-2.0 } 17 | { } 18 | { Unless required by applicable law or agreed to in writing, software } 19 | { distributed under the License is distributed on an "AS IS" BASIS, } 20 | { WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } 21 | { See the License for the specific language governing permissions and } 22 | { limitations under the License. } 23 | { } 24 | {******************************************************************************} 25 | unit FRExport; 26 | 27 | interface 28 | 29 | uses 30 | frxClass, FRExport.Interfaces, FRExport.Core; 31 | 32 | type 33 | 34 | TFRExport = class(TFRExportCustom) 35 | private 36 | { private declarations } 37 | protected 38 | { protected declarations } 39 | public 40 | { public declarations } 41 | class function New: IFRExport; 42 | end; 43 | 44 | TFRExportProviderPDF = class(TFRExportProviderPDFCustom); 45 | TFRExportProviderHTML = class(TFRExportProviderHTMLCustom); 46 | TFRExportProviderPNG = class(TFRExportProviderPNGCustom); 47 | TFRExportProviderBMP = class(TFRExportProviderBMPCustom); 48 | TFRExportProviderJPEG = class(TFRExportProviderJPEGCustom); 49 | TFRExportProviderCSV = class(TFRExportProviderCSVCustom); 50 | TFRExportProviderRTF = class(TFRExportProviderRTFCustom); 51 | TFRExportProviderXLS = class(TFRExportProviderXLSCustom); 52 | TFRExportProviderXLSX = class(TFRExportProviderXLSXCustom); 53 | TFRExportProviderDOCX = class(TFRExportProviderDOCXCustom); 54 | 55 | implementation 56 | 57 | { TFRExport } 58 | 59 | class function TFRExport.New: IFRExport; 60 | begin 61 | Result := Self.Create; 62 | end; 63 | 64 | end. 65 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.Param.Header.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.Param.Header; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Classes, Generics.Collections, fpHTTP, fphttpserver, httpprotocol, HTTPDefs, 12 | {$ELSE} 13 | System.Classes, System.SysUtils, System.Generics.Collections, 14 | Web.HTTPApp, IdCustomHTTPServer, IdHeaderList, Horse.Rtti, 15 | {$ENDIF} 16 | Horse.Core.Param, Horse.Commons, Horse.Rtti.Helper; 17 | 18 | type 19 | THorseCoreParamHeader = class 20 | private 21 | class function GetHeadersList(const AWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}): TStrings; 22 | public 23 | class function GetHeaders(const AWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}): THorseList; 24 | end; 25 | 26 | implementation 27 | 28 | class function THorseCoreParamHeader.GetHeaders(const AWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}): THorseList; 29 | var 30 | I: Integer; 31 | LName, LValue: string; 32 | LHeaders: TStrings; 33 | begin 34 | Result := THorseList.create; 35 | try 36 | LHeaders := GetHeadersList(AWebRequest); 37 | try 38 | for I := 0 to Pred(LHeaders.Count) do 39 | begin 40 | LName := LHeaders.Names[I]; 41 | LValue := LHeaders.Values[LName]; 42 | Result.AddOrSetValue(LName, Trim(LValue)); 43 | end; 44 | {$IF DEFINED(FPC)} 45 | for I := Integer(Low(THeader)) to Integer(High(THeader)) do 46 | begin 47 | LName := HTTPHeaderNames[THeader(I)]; 48 | LValue := AWebRequest.GetHeader(THeader(I)); 49 | if not LValue.Trim.IsEmpty then 50 | Result.AddOrSetValue(LName, LValue); 51 | end; 52 | {$ENDIF} 53 | finally 54 | LHeaders.Free; 55 | end; 56 | except 57 | Result.Free; 58 | raise; 59 | end; 60 | end; 61 | 62 | class function THorseCoreParamHeader.GetHeadersList(const AWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}): TStrings; 63 | {$IF NOT DEFINED(HORSE_ISAPI)} 64 | var 65 | LRequest: {$IF DEFINED(FPC)} TFPHTTPConnectionRequest {$ELSE} TIdHTTPRequestInfo {$ENDIF}; 66 | {$IF NOT DEFINED(FPC)} 67 | LObject: TObject; 68 | {$ENDIF} 69 | {$ENDIF} 70 | begin 71 | Result := TStringList.Create; 72 | try 73 | Result.NameValueSeparator := ':'; 74 | {$IF DEFINED(FPC)} 75 | if AWebRequest is TFPHTTPConnectionRequest then 76 | begin 77 | LRequest := TFPHTTPConnectionRequest(AWebRequest); 78 | Result.NameValueSeparator := '='; 79 | Result.Text := LRequest.CustomHeaders.Text; 80 | end; 81 | {$ELSEIF DEFINED(HORSE_ISAPI)} 82 | Result.Text := AWebRequest.GetFieldByName('ALL_RAW'); 83 | {$ELSE} 84 | LObject := THorseRtti.GetInstance.GetType(AWebRequest.ClassType).FieldValueAsObject(AWebRequest, 'FRequestInfo'); 85 | if (Assigned(LObject)) and (LObject is TIdHTTPRequestInfo) then 86 | begin 87 | LRequest := TIdHTTPRequestInfo(LObject); 88 | Result.Text := LRequest.RawHeaders.Text; 89 | end; 90 | {$ENDIF} 91 | except 92 | Result.Free; 93 | raise; 94 | end; 95 | end; 96 | 97 | end. 98 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Exception.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Exception; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, 12 | {$ELSE} 13 | System.SysUtils, 14 | {$ENDIF} 15 | Horse.Commons; 16 | 17 | type 18 | EHorseException = class(Exception) 19 | strict private 20 | FError: string; 21 | FUnit: string; 22 | FTitle: string; 23 | FCode: Integer; 24 | FStatus: THTTPStatus; 25 | FType: TMessageType; 26 | constructor Create; reintroduce; 27 | public 28 | class function New: EHorseException; 29 | function Error(const AValue: string): EHorseException; overload; 30 | function Error: string; overload; 31 | function Title(const AValue: string): EHorseException; overload; 32 | function Title: string; overload; 33 | function &Unit(const AValue: string): EHorseException; overload; 34 | function &Unit: string; overload; 35 | function Code(const AValue: Integer): EHorseException; overload; 36 | function Code: Integer; overload; 37 | function Status(const AValue: THTTPStatus): EHorseException; overload; 38 | function Status: THTTPStatus; overload; 39 | function &Type(const AValue: TMessageType): EHorseException; overload; 40 | function &Type: TMessageType; overload; 41 | end; 42 | 43 | implementation 44 | 45 | function EHorseException.Code(const AValue: Integer): EHorseException; 46 | begin 47 | FCode := AValue; 48 | Result := Self; 49 | end; 50 | 51 | function EHorseException.&Type: TMessageType; 52 | begin 53 | Result := FType; 54 | end; 55 | 56 | function EHorseException.&Type(const AValue: TMessageType): EHorseException; 57 | begin 58 | FType := AValue; 59 | Result := Self; 60 | end; 61 | 62 | function EHorseException.Code: Integer; 63 | begin 64 | Result := FCode; 65 | end; 66 | 67 | function EHorseException.&Unit: string; 68 | begin 69 | Result := FUnit; 70 | end; 71 | 72 | function EHorseException.&Unit(const AValue: string): EHorseException; 73 | begin 74 | FUnit := AValue; 75 | Result := Self; 76 | end; 77 | 78 | constructor EHorseException.Create; 79 | begin 80 | FError := EmptyStr; 81 | FStatus := THTTPStatus.InternalServerError; 82 | FCode := 0; 83 | end; 84 | 85 | function EHorseException.Error: string; 86 | begin 87 | Result := FError; 88 | end; 89 | 90 | function EHorseException.Error(const AValue: string): EHorseException; 91 | begin 92 | FError := AValue; 93 | Result := Self; 94 | end; 95 | 96 | class function EHorseException.New: EHorseException; 97 | begin 98 | Result := EHorseException.Create; 99 | end; 100 | 101 | function EHorseException.Status: THTTPStatus; 102 | begin 103 | Result := FStatus; 104 | end; 105 | 106 | function EHorseException.Status(const AValue: THTTPStatus): EHorseException; 107 | begin 108 | FStatus := AValue; 109 | Result := Self; 110 | end; 111 | 112 | function EHorseException.Title(const AValue: string): EHorseException; 113 | begin 114 | FTitle := AValue; 115 | Result := Self; 116 | end; 117 | 118 | function EHorseException.Title: string; 119 | begin 120 | Result := FTitle; 121 | end; 122 | 123 | end. 124 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.WebModule.pas: -------------------------------------------------------------------------------- 1 | unit Horse.WebModule; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Classes, httpdefs, fpHTTP, fpWeb, 12 | {$ELSE} 13 | System.SysUtils, System.Classes, Web.HTTPApp, 14 | {$ENDIF} 15 | Horse.Core, Horse.Commons; 16 | 17 | type 18 | {$IF DEFINED(FPC)} 19 | THorseWebModule = class(TFPWebModule) 20 | procedure DoOnRequest(ARequest: TRequest; AResponse: TResponse; var AHandled: Boolean); override; 21 | {$ELSE} 22 | THorseWebModule = class(TWebModule) 23 | {$ENDIF} 24 | procedure HandlerAction(const Sender: TObject; const Request: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}; const Response: {$IF DEFINED(FPC)}TResponse{$ELSE}TWebResponse{$ENDIF}; var Handled: Boolean); 25 | private 26 | FHorse: THorseCore; 27 | class var FInstance: THorseWebModule; 28 | public 29 | property Horse: THorseCore read FHorse write FHorse; 30 | constructor Create(AOwner: TComponent); override; 31 | class function GetInstance: THorseWebModule; 32 | end; 33 | 34 | var 35 | {$IF DEFINED(FPC)} 36 | HorseWebModule: THorseWebModule; 37 | {$ELSE} 38 | WebModuleClass: TComponentClass = THorseWebModule; 39 | {$ENDIF} 40 | 41 | implementation 42 | 43 | uses Horse.Request, Horse.Response, Horse.Exception, Horse.Exception.Interrupted; 44 | 45 | {$IF DEFINED(FPC)} 46 | {$R Horse.WebModule.lfm} 47 | {$ELSE} 48 | {$R *.dfm} 49 | {$ENDIF} 50 | 51 | class function THorseWebModule.GetInstance: THorseWebModule; 52 | begin 53 | Result := FInstance; 54 | end; 55 | 56 | constructor THorseWebModule.Create(AOwner: TComponent); 57 | begin 58 | {$IF DEFINED(FPC)} 59 | inherited CreateNew(AOwner, 0); 60 | {$ELSE} 61 | inherited; 62 | {$ENDIF} 63 | FHorse := THorseCore.GetInstance; 64 | FInstance := Self; 65 | end; 66 | 67 | {$IF DEFINED(FPC)} 68 | procedure THorseWebModule.DoOnRequest(ARequest: {$IF DEFINED(FPC)}TRequest{$ELSE} TWebRequest {$ENDIF}; AResponse: {$IF DEFINED(FPC)}TResponse{$ELSE} TWebResponse {$ENDIF}; var AHandled: Boolean); 69 | begin 70 | HandlerAction(Self, ARequest, AResponse, AHandled); 71 | end; 72 | {$ENDIF} 73 | 74 | procedure THorseWebModule.HandlerAction(const Sender: TObject; const Request: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}; 75 | const Response: {$IF DEFINED(FPC)}TResponse{$ELSE}TWebResponse{$ENDIF}; var Handled: Boolean); 76 | var 77 | LRequest: THorseRequest; 78 | LResponse: THorseResponse; 79 | begin 80 | Handled := True; 81 | LRequest := THorseRequest.Create(Request); 82 | LResponse := THorseResponse.Create(Response); 83 | try 84 | try 85 | FHorse.Routes.Execute(LRequest, LResponse) 86 | except 87 | on E: Exception do 88 | if not E.InheritsFrom(EHorseCallbackInterrupted) then 89 | raise; 90 | end; 91 | finally 92 | if LRequest.Body = LResponse.Content then 93 | LResponse.Content(nil); 94 | LRequest.Free; 95 | LResponse.Free; 96 | end; 97 | end; 98 | 99 | {$IF DEFINED(FPC)} 100 | initialization 101 | RegisterHTTPModule(THorseWebModule); 102 | {$ENDIF} 103 | 104 | end. 105 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.pas: -------------------------------------------------------------------------------- 1 | unit Horse; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, 12 | Horse.Provider.FPC.HTTPApplication, 13 | Horse.Provider.FPC.Apache, 14 | Horse.Provider.FPC.CGI, 15 | Horse.Provider.FPC.FastCGI, 16 | Horse.Provider.FPC.Daemon, 17 | Horse.Provider.FPC.LCL, 18 | {$ELSE} 19 | System.SysUtils, 20 | Horse.Provider.Console, 21 | Horse.Provider.Daemon, 22 | Horse.Provider.ISAPI, 23 | Horse.Provider.Apache, 24 | Horse.Provider.CGI, 25 | Horse.Provider.VCL, 26 | {$ENDIF} 27 | Horse.Core, 28 | Horse.Proc, 29 | Horse.Request, 30 | Horse.Response, 31 | Horse.Commons, 32 | Horse.Core.Param, 33 | Horse.Core.RouterTree, 34 | Horse.Exception, 35 | Horse.Exception.Interrupted, 36 | Horse.Provider.Abstract, 37 | Horse.Core.Param.Config, 38 | Horse.Callback; 39 | 40 | type 41 | EHorseException = Horse.Exception.EHorseException; 42 | EHorseCallbackInterrupted = Horse.Exception.Interrupted.EHorseCallbackInterrupted; 43 | TProc = Horse.Proc.TProc; 44 | TNextProc = Horse.Proc.TNextProc; 45 | THorseList = Horse.Core.Param.THorseList; 46 | THorseCoreParam = Horse.Core.Param.THorseCoreParam; 47 | THorseCoreParamConfig = Horse.Core.Param.Config.THorseCoreParamConfig; 48 | THorseRequest = Horse.Request.THorseRequest; 49 | THorseResponse = Horse.Response.THorseResponse; 50 | THorseCallback = Horse.Callback.THorseCallback; 51 | THTTPStatus = Horse.Commons.THTTPStatus; 52 | TMimeTypes = Horse.Commons.TMimeTypes; 53 | TMessageType = Horse.Commons.TMessageType; 54 | THorseModule = Horse.Core.THorseModule; 55 | PHorseModule = Horse.Core.PHorseModule; 56 | PHorseCore = Horse.Core.PHorseCore; 57 | PHorseRouterTree = Horse.Core.RouterTree.PHorseRouterTree; 58 | 59 | THorse = class; 60 | 61 | {$IF DEFINED(HORSE_ISAPI)} 62 | THorseProvider = Horse.Provider.ISAPI.THorseProvider; 63 | {$ELSEIF DEFINED(HORSE_APACHE)} 64 | THorseProvider = 65 | {$IF DEFINED(FPC)} 66 | Horse.Provider.FPC.Apache.THorseProvider; 67 | {$ELSE} 68 | Horse.Provider.Apache.THorseProvider; 69 | {$ENDIF} 70 | {$ELSEIF DEFINED(HORSE_CGI)} 71 | THorseProvider = 72 | {$IF DEFINED(FPC)} 73 | Horse.Provider.FPC.CGI.THorseProvider; 74 | {$ELSE} 75 | Horse.Provider.CGI.THorseProvider; 76 | {$ENDIF} 77 | {$ELSEIF DEFINED(HORSE_FCGI)} 78 | THorseProvider = 79 | {$IF DEFINED(FPC)} 80 | Horse.Provider.FPC.FastCGI.THorseProvider; 81 | {$ENDIF} 82 | {$ELSEIF DEFINED(HORSE_DAEMON)} 83 | THorseProvider = 84 | {$IF DEFINED(FPC)} 85 | Horse.Provider.FPC.Daemon.THorseProvider; 86 | {$ELSE} 87 | Horse.Provider.Daemon.THorseProvider; 88 | {$ENDIF} 89 | {$ELSEIF DEFINED(HORSE_LCL)} 90 | THorseProvider = Horse.Provider.FPC.LCL.THorseProvider; 91 | {$ELSEIF DEFINED(HORSE_VCL)} 92 | THorseProvider = Horse.Provider.VCL.THorseProvider; 93 | {$ELSE} 94 | THorseProvider = 95 | {$IF DEFINED(FPC)} 96 | Horse.Provider.FPC.HTTPApplication.THorseProvider; 97 | {$ELSE} 98 | Horse.Provider.Console.THorseProvider; 99 | {$ENDIF} 100 | {$ENDIF} 101 | 102 | THorse = class(THorseProvider); 103 | 104 | implementation 105 | 106 | end. 107 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.Route.Contract.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.Route.Contract; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses Horse.Core.RouterTree, Horse.Callback; 10 | 11 | type 12 | IHorseCoreRoute = interface 13 | ['{8D593D98-44B3-4FD2-A21B-BA29F784B3AA}'] 14 | function AddCallback(const ACallback: THorseCallback): IHorseCoreRoute; 15 | function AddCallbacks(const ACallbacks: TArray): IHorseCoreRoute; 16 | 17 | function All(const ACallback: THorseCallback): IHorseCoreRoute; overload; 18 | function All(const AMiddleware, ACallback: THorseCallback): IHorseCoreRoute; overload; 19 | function All(const ACallbacks: array of THorseCallback): IHorseCoreRoute; overload; 20 | function All(const ACallbacks: array of THorseCallback; const ACallback: THorseCallback): IHorseCoreRoute; overload; 21 | 22 | function Get(const ACallback: THorseCallback): IHorseCoreRoute; overload; 23 | function Get(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 24 | function Get(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 25 | {$IFNDEF FPC} 26 | function Get(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 27 | {$IFEND} 28 | 29 | function Put(const ACallback: THorseCallback): IHorseCoreRoute; overload; 30 | function Put(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 31 | function Put(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 32 | {$IFNDEF FPC} 33 | function Put(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 34 | {$IFEND} 35 | 36 | function Head(const ACallback: THorseCallback): IHorseCoreRoute; overload; 37 | function Head(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 38 | function Head(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 39 | {$IFNDEF FPC} 40 | function Head(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 41 | {$IFEND} 42 | 43 | function Post(const ACallback: THorseCallback): IHorseCoreRoute; overload; 44 | function Post(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 45 | function Post(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 46 | {$IFNDEF FPC} 47 | function Post(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 48 | {$IFEND} 49 | 50 | {$IF (DEFINED(FPC) OR (CompilerVersion > 27.0))} 51 | function Patch(const ACallback: THorseCallback): IHorseCoreRoute; overload; 52 | function Delete(const ACallback: THorseCallback): IHorseCoreRoute; overload; 53 | 54 | function Patch(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 55 | function Patch(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 56 | {$IFNDEF FPC} 57 | function Patch(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 58 | {$IFEND} 59 | 60 | function Delete(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 61 | function Delete(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 62 | {$IFNDEF FPC} 63 | function Delete(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 64 | {$IFEND} 65 | {$IFEND} 66 | 67 | function &End: T; 68 | end; 69 | 70 | implementation 71 | 72 | end. 73 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.IOHandleSSL.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.IOHandleSSL; 2 | 3 | interface 4 | 5 | uses IdSSLOpenSSL; 6 | 7 | type 8 | THorseProviderIOHandleSSL = class 9 | private 10 | FKeyFile: string; 11 | FRootCertFile: string; 12 | FCertFile: string; 13 | FMethod: TIdSSLVersion; 14 | FSSLVersions: TIdSSLVersions; 15 | FOnGetPassword: TPasswordEvent; 16 | FActive: Boolean; 17 | procedure SetCertFile(const AValue: string); 18 | procedure SetKeyFile(const AValue: string); 19 | procedure SetRootCertFile(const AValue: string); 20 | procedure SetMethod(const AValue: TIdSSLVersion); 21 | procedure SetSSLVersions(const AValue: TIdSSLVersions); 22 | procedure SetOnGetPassword(const AValue: TPasswordEvent); 23 | procedure SetActive(const AValue: Boolean); 24 | function GetCertFile: string; 25 | function GetKeyFile: string; 26 | function GetRootCertFile: string; 27 | function GetMethod: TIdSSLVersion; 28 | function GetSSLVersions: TIdSSLVersions; 29 | function GetOnGetPassword: TPasswordEvent; 30 | function GetActive: Boolean; 31 | public 32 | constructor Create; 33 | property Active: Boolean read GetActive write SetActive default True; 34 | property CertFile: string read GetCertFile write SetCertFile; 35 | property RootCertFile: string read GetRootCertFile write SetRootCertFile; 36 | property KeyFile: string read GetKeyFile write SetKeyFile; 37 | property Method: TIdSSLVersion read GetMethod write SetMethod; 38 | property SSLVersions: TIdSSLVersions read GetSSLVersions write SetSSLVersions; 39 | property OnGetPassword: TPasswordEvent read GetOnGetPassword write SetOnGetPassword; 40 | end; 41 | 42 | implementation 43 | 44 | constructor THorseProviderIOHandleSSL.Create; 45 | begin 46 | FActive := True; 47 | FMethod := DEF_SSLVERSION; 48 | FSSLVersions := DEF_SSLVERSIONS; 49 | end; 50 | 51 | function THorseProviderIOHandleSSL.GetActive: Boolean; 52 | begin 53 | Result := FActive; 54 | end; 55 | 56 | function THorseProviderIOHandleSSL.GetCertFile: string; 57 | begin 58 | Result := FCertFile; 59 | end; 60 | 61 | function THorseProviderIOHandleSSL.GetKeyFile: string; 62 | begin 63 | Result := FKeyFile; 64 | end; 65 | 66 | function THorseProviderIOHandleSSL.GetOnGetPassword: TPasswordEvent; 67 | begin 68 | Result := FOnGetPassword; 69 | end; 70 | 71 | function THorseProviderIOHandleSSL.GetRootCertFile: string; 72 | begin 73 | Result := FRootCertFile; 74 | end; 75 | 76 | function THorseProviderIOHandleSSL.GetMethod: TIdSSLVersion; 77 | begin 78 | Result := FMethod; 79 | end; 80 | 81 | function THorseProviderIOHandleSSL.GetSSLVersions: TIdSSLVersions; 82 | begin 83 | Result := FSSLVersions; 84 | end; 85 | 86 | procedure THorseProviderIOHandleSSL.SetActive(const AValue: Boolean); 87 | begin 88 | FActive := AValue; 89 | end; 90 | 91 | procedure THorseProviderIOHandleSSL.SetCertFile(const AValue: string); 92 | begin 93 | FCertFile := AValue; 94 | end; 95 | 96 | procedure THorseProviderIOHandleSSL.SetSSLVersions(const AValue: TIdSSLVersions); 97 | begin 98 | FSSLVersions := AValue; 99 | end; 100 | 101 | procedure THorseProviderIOHandleSSL.SetMethod(const AValue: TIdSSLVersion); 102 | begin 103 | FMethod := AValue; 104 | end; 105 | 106 | procedure THorseProviderIOHandleSSL.SetKeyFile(const AValue: string); 107 | begin 108 | FKeyFile := AValue; 109 | end; 110 | 111 | procedure THorseProviderIOHandleSSL.SetOnGetPassword(const AValue: TPasswordEvent); 112 | begin 113 | FOnGetPassword := AValue; 114 | end; 115 | 116 | procedure THorseProviderIOHandleSSL.SetRootCertFile(const AValue: string); 117 | begin 118 | FRootCertFile := AValue; 119 | end; 120 | 121 | end. -------------------------------------------------------------------------------- /Samples/Postman/FastReportExport.postman_collection_v2.1.json: -------------------------------------------------------------------------------- 1 | { 2 | "info": { 3 | "_postman_id": "7f1185c0-f128-4aac-90c0-6c5c7c82d828", 4 | "name": "Fast Report Export", 5 | "schema": "https://schema.getpostman.com/json/collection/v2.1.0/collection.json" 6 | }, 7 | "item": [ 8 | { 9 | "name": "Request VCL", 10 | "event": [ 11 | { 12 | "listen": "test", 13 | "script": { 14 | "exec": [ 15 | "tests[\"VCL Status\"] = responseCode.code === 200;" 16 | ], 17 | "type": "text/javascript" 18 | } 19 | } 20 | ], 21 | "request": { 22 | "method": "GET", 23 | "header": [], 24 | "url": { 25 | "raw": "http://localhost:9000/export/43", 26 | "protocol": "http", 27 | "host": [ 28 | "localhost" 29 | ], 30 | "port": "9000", 31 | "path": [ 32 | "export", 33 | "43" 34 | ] 35 | } 36 | }, 37 | "response": [] 38 | }, 39 | { 40 | "name": "Request Console", 41 | "event": [ 42 | { 43 | "listen": "test", 44 | "script": { 45 | "exec": [ 46 | "tests[\"Console Status\"] = responseCode.code === 200;" 47 | ], 48 | "type": "text/javascript" 49 | } 50 | } 51 | ], 52 | "request": { 53 | "method": "GET", 54 | "header": [], 55 | "url": { 56 | "raw": "http://localhost:9001/export/43", 57 | "protocol": "http", 58 | "host": [ 59 | "localhost" 60 | ], 61 | "port": "9001", 62 | "path": [ 63 | "export", 64 | "43" 65 | ] 66 | } 67 | }, 68 | "response": [] 69 | }, 70 | { 71 | "name": "Request Windows Service", 72 | "event": [ 73 | { 74 | "listen": "test", 75 | "script": { 76 | "exec": [ 77 | "tests[\"WindowsService Status\"] = responseCode.code === 200;" 78 | ], 79 | "type": "text/javascript" 80 | } 81 | } 82 | ], 83 | "request": { 84 | "method": "GET", 85 | "header": [], 86 | "url": { 87 | "raw": "http://localhost:9002/export/43", 88 | "protocol": "http", 89 | "host": [ 90 | "localhost" 91 | ], 92 | "port": "9002", 93 | "path": [ 94 | "export", 95 | "43" 96 | ] 97 | } 98 | }, 99 | "response": [] 100 | }, 101 | { 102 | "name": "Request ISAPI", 103 | "event": [ 104 | { 105 | "listen": "test", 106 | "script": { 107 | "exec": [ 108 | "tests[\"ISAPI Status\"] = responseCode.code === 200;" 109 | ], 110 | "type": "text/javascript" 111 | } 112 | } 113 | ], 114 | "request": { 115 | "method": "GET", 116 | "header": [], 117 | "url": { 118 | "raw": "http://localhost/frxexportisapi/ISAPI.dll/export/43", 119 | "protocol": "http", 120 | "host": [ 121 | "localhost" 122 | ], 123 | "path": [ 124 | "frxexportisapi", 125 | "ISAPI.dll", 126 | "export", 127 | "43" 128 | ] 129 | } 130 | }, 131 | "response": [] 132 | }, 133 | { 134 | "name": "Request CGI", 135 | "event": [ 136 | { 137 | "listen": "test", 138 | "script": { 139 | "exec": [ 140 | "tests[\"CGI Status\"] = responseCode.code === 200;" 141 | ], 142 | "type": "text/javascript" 143 | } 144 | } 145 | ], 146 | "request": { 147 | "method": "GET", 148 | "header": [], 149 | "url": { 150 | "raw": "http://localhost/frxexportcgi/cgi.exe/export/43", 151 | "protocol": "http", 152 | "host": [ 153 | "localhost" 154 | ], 155 | "path": [ 156 | "frxexportcgi", 157 | "cgi.exe", 158 | "export", 159 | "43" 160 | ] 161 | } 162 | }, 163 | "response": [] 164 | } 165 | ] 166 | } -------------------------------------------------------------------------------- /Source/FRExport.Interfaces.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | { } 3 | { FRExport } 4 | { } 5 | { Copyright (C) Antônio José Medeiros Schneider Júnior } 6 | { } 7 | { https://github.com/antoniojmsjr/FastReportExport } 8 | { } 9 | { } 10 | {******************************************************************************} 11 | { } 12 | { Licensed under the Apache License, Version 2.0 (the "License"); } 13 | { you may not use this file except in compliance with the License. } 14 | { You may obtain a copy of the License at } 15 | { } 16 | { http://www.apache.org/licenses/LICENSE-2.0 } 17 | { } 18 | { Unless required by applicable law or agreed to in writing, software } 19 | { distributed under the License is distributed on an "AS IS" BASIS, } 20 | { WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } 21 | { See the License for the specific language governing permissions and } 22 | { limitations under the License. } 23 | { } 24 | {******************************************************************************} 25 | unit FRExport.Interfaces; 26 | 27 | interface 28 | 29 | uses 30 | System.Classes, Data.DB, frxClass, frxDBSet, FRExport.Types, 31 | FRExport.Interfaces.Providers; 32 | 33 | type 34 | IFRExportExecute = interface; 35 | IFRExportDataSets = interface; 36 | IFRExportProviders = interface; 37 | 38 | IFRExport = interface 39 | ['{BB3644C1-048D-4730-949A-9A1083E3AA72}'] 40 | function GetFRExportExecute: IFRExportExecute; 41 | function GetExportDataSets: IFRExportDataSets; 42 | function GetExportProviders: IFRExportProviders; 43 | 44 | property DataSets: IFRExportDataSets read GetExportDataSets; 45 | property Providers: IFRExportProviders read GetExportProviders; 46 | property Export: IFRExportExecute read GetFRExportExecute; 47 | end; 48 | 49 | IFRExportDataSets = interface 50 | ['{9A66A228-A834-4273-8F42-F825FE508F87}'] 51 | function GetEnd: IFRExport; 52 | function SetDataSet(DataSet: TDataSet; const UserName: string): IFRExportDataSets; overload; 53 | function SetDataSet(DataSet: TfrxDBDataset): IFRExportDataSets; overload; 54 | 55 | property &End: IFRExport read GetEnd; 56 | end; 57 | 58 | IFRExportProviders = interface 59 | ['{543D70DA-CFFB-413A-B29D-940BC4B8399A}'] 60 | function GetEnd: IFRExport; 61 | function SetProvider(Provider: IFRExportProvider): IFRExportProviders; 62 | 63 | property &End: IFRExport read GetEnd; 64 | end; 65 | 66 | IFRExportExecute = interface 67 | ['{50125DEF-BE3B-4FD2-9819-A5D4849663F9}'] 68 | function SetExceptionFastReport(const Value: Boolean): IFRExportExecute; 69 | function SetFileReport(const FileName: string): IFRExportExecute; overload; 70 | function SetFileReport(FileStream: TStream): IFRExportExecute; overload; 71 | function Report(const CallbackReport: TFRExportReportCallback): IFRExportExecute; 72 | procedure Execute; 73 | end; 74 | 75 | implementation 76 | 77 | end. 78 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.FPC.Apache.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.FPC.Apache; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | {$IF DEFINED(HORSE_APACHE) AND DEFINED(FPC)} 10 | uses 11 | {$IFDEF unix} 12 | cthreads, 13 | {$ENDIF} 14 | fphttp, httpdefs, httpd24, fpApache24, custapache24, SysUtils, Classes, Horse.Provider.Abstract, 15 | Horse.Constants, Horse.Proc; 16 | 17 | type 18 | THorseProvider = class(THorseProviderAbstract) 19 | private 20 | class var FApacheApplication: TCustomApacheApplication; 21 | class var FHandlerName: string; 22 | class var FModuleName: string; 23 | class var FDefaultModule: pmodule; 24 | class function GetDefaultApacheApplication: TCustomApacheApplication; 25 | class function ApacheApplicationIsNil: Boolean; 26 | class procedure InternalListen; virtual; 27 | class procedure SetHandlerName(const AValue: string); static; 28 | class function GetHandlerName: string; static; 29 | class procedure SetModuleName(const AValue: string); static; 30 | class function GetModuleName: string; static; 31 | class procedure SetDefaultModule(const AValue: pmodule); static; 32 | class function GetDefaultModule: pmodule; static; 33 | class procedure DoGetModule(Sender: TObject; ARequest: TRequest; var pmoduleClass: TCustomHTTPModuleClass); 34 | public 35 | class property HandlerName: string read GetHandlerName write SetHandlerName; 36 | class property ModuleName: string read GetModuleName write SetModuleName; 37 | class property DefaultModule: pmodule read GetDefaultModule write SetDefaultModule; 38 | class procedure Listen; overload; override; 39 | class procedure Listen(const ACallback: TProc); reintroduce; overload; static; 40 | end; 41 | {$ENDIF} 42 | 43 | implementation 44 | 45 | {$IF DEFINED(HORSE_APACHE) AND DEFINED(FPC)} 46 | uses Horse.WebModule; 47 | 48 | class function THorseProvider.GetDefaultApacheApplication: TCustomApacheApplication; 49 | begin 50 | if ApacheApplicationIsNil then 51 | FApacheApplication := Application; 52 | Result := FApacheApplication; 53 | end; 54 | 55 | class function THorseProvider.GetDefaultModule: pmodule; 56 | begin 57 | Result := FDefaultModule; 58 | end; 59 | 60 | class function THorseProvider.GetHandlerName: string; 61 | begin 62 | Result := FHandlerName; 63 | end; 64 | 65 | class procedure THorseProvider.SetModuleName(const AValue: string); 66 | begin 67 | FModuleName := AValue; 68 | end; 69 | 70 | class function THorseProvider.GetModuleName: string; 71 | begin 72 | Result:= FModuleName; 73 | end; 74 | 75 | class function THorseProvider.ApacheApplicationIsNil: Boolean; 76 | begin 77 | Result := FApacheApplication = nil; 78 | end; 79 | 80 | class procedure THorseProvider.InternalListen; 81 | var 82 | LApacheApplication: TCustomApacheApplication; 83 | begin 84 | inherited; 85 | LApacheApplication := GetDefaultApacheApplication; 86 | LApacheApplication.ModuleName := FModuleName; 87 | LApacheApplication.HandlerName := FHandlerName; 88 | LApacheApplication.SetModuleRecord(FDefaultModule^); 89 | LApacheApplication.AllowDefaultModule := True; 90 | LApacheApplication.OnGetModule := DoGetModule; 91 | LApacheApplication.LegacyRouting := True; 92 | DoOnListen; 93 | LApacheApplication.Initialize; 94 | end; 95 | 96 | class procedure THorseProvider.DoGetModule(Sender: TObject; ARequest: TRequest; var pmoduleClass: TCustomHTTPModuleClass); 97 | begin 98 | pmoduleClass := THorseWebModule; 99 | end; 100 | 101 | class procedure THorseProvider.SetDefaultModule(const AValue: pmodule); 102 | begin 103 | FDefaultModule := AValue; 104 | end; 105 | 106 | class procedure THorseProvider.SetHandlerName(const AValue: string); 107 | begin 108 | FHandlerName := AValue; 109 | end; 110 | 111 | class procedure THorseProvider.Listen; 112 | begin 113 | InternalListen; 114 | end; 115 | 116 | class procedure THorseProvider.Listen(const ACallback: TProc); 117 | begin 118 | SetOnListen(ACallback); 119 | InternalListen; 120 | end; 121 | {$ENDIF} 122 | 123 | end. 124 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.Group.Contract.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.Group.Contract; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses Horse.Core.Route.Contract, Horse.Core.RouterTree, Horse.Callback; 10 | 11 | type 12 | IHorseCoreGroup = interface 13 | ['{5EB734D6-6944-473E-9C79-506647E2F5E8}'] 14 | function Prefix(const APrefix: string): IHorseCoreGroup; 15 | function Route(const APath: string): IHorseCoreRoute; 16 | 17 | function AddCallback(const ACallback: THorseCallback): IHorseCoreGroup; 18 | function AddCallbacks(const ACallbacks: TArray): IHorseCoreGroup; 19 | 20 | function Use(const ACallback: THorseCallback): IHorseCoreGroup; overload; 21 | function Use(const AMiddleware, ACallback: THorseCallback): IHorseCoreGroup; overload; 22 | function Use(const ACallbacks: array of THorseCallback): IHorseCoreGroup; overload; 23 | function Use(const ACallbacks: array of THorseCallback; const ACallback: THorseCallback): IHorseCoreGroup; overload; 24 | 25 | function Get(const APath: string; const ACallback: THorseCallback): IHorseCoreGroup; overload; 26 | function Get(const APath: string; const ACallback: THorseCallbackRequestResponse): IHorseCoreGroup; overload; 27 | function Get(const APath: string; const ACallback: THorseCallbackRequest): IHorseCoreGroup; overload; 28 | {$IFNDEF FPC} 29 | function Get(const APath: string; const ACallback: THorseCallbackResponse): IHorseCoreGroup; overload; 30 | {$IFEND} 31 | 32 | function Put(const APath: string; const ACallback: THorseCallback): IHorseCoreGroup; overload; 33 | function Put(const APath: string; const ACallback: THorseCallbackRequestResponse): IHorseCoreGroup; overload; 34 | function Put(const APath: string; const ACallback: THorseCallbackRequest): IHorseCoreGroup; overload; 35 | {$IFNDEF FPC} 36 | function Put(const APath: string; const ACallback: THorseCallbackResponse): IHorseCoreGroup; overload; 37 | {$IFEND} 38 | 39 | function Head(const APath: string; const ACallback: THorseCallback): IHorseCoreGroup; overload; 40 | function Head(const APath: string; const ACallback: THorseCallbackRequestResponse): IHorseCoreGroup; overload; 41 | function Head(const APath: string; const ACallback: THorseCallbackRequest): IHorseCoreGroup; overload; 42 | {$IFNDEF FPC} 43 | function Head(const APath: string; const ACallback: THorseCallbackResponse): IHorseCoreGroup; overload; 44 | {$IFEND} 45 | 46 | function Post(const APath: string; const ACallback: THorseCallback): IHorseCoreGroup; overload; 47 | function Post(const APath: string; const ACallback: THorseCallbackRequestResponse): IHorseCoreGroup; overload; 48 | function Post(const APath: string; const ACallback: THorseCallbackRequest): IHorseCoreGroup; overload; 49 | {$IFNDEF FPC} 50 | function Post(const APath: string; const ACallback: THorseCallbackResponse): IHorseCoreGroup; overload; 51 | {$IFEND} 52 | 53 | {$IF (defined(fpc) or (CompilerVersion > 27.0))} 54 | function Patch(const APath: string; const ACallback: THorseCallback): IHorseCoreGroup; overload; 55 | function Delete(const APath: string; const ACallback: THorseCallback): IHorseCoreGroup; overload; 56 | 57 | function Patch(const APath: string; const ACallback: THorseCallbackRequestResponse): IHorseCoreGroup; overload; 58 | function Patch(const APath: string; const ACallback: THorseCallbackRequest): IHorseCoreGroup; overload; 59 | {$IFNDEF FPC} 60 | function Patch(const APath: string; const ACallback: THorseCallbackResponse): IHorseCoreGroup; overload; 61 | {$IFEND} 62 | 63 | function Delete(const APath: string; const ACallback: THorseCallbackRequestResponse): IHorseCoreGroup; overload; 64 | function Delete(const APath: string; const ACallback: THorseCallbackRequest): IHorseCoreGroup; overload; 65 | {$IFNDEF FPC} 66 | function Delete(const APath: string; const ACallback: THorseCallbackResponse): IHorseCoreGroup; overload; 67 | {$IFEND} 68 | {$IFEND} 69 | 70 | function &End: T; 71 | end; 72 | 73 | implementation 74 | 75 | end. 76 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.Param.Config.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.Param.Config; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | type 10 | 11 | { THorseCoreParamConfig } 12 | 13 | THorseCoreParamConfig = class 14 | private 15 | class var FInstance: THorseCoreParamConfig; 16 | FRequiredMessage: string; 17 | FInvalidFormatMessage: string; 18 | FDateFormat: string; 19 | FTimeFormat: string; 20 | FReturnUTC: Boolean; 21 | FTrueValue: string; 22 | FCheckLhsBrackets: Boolean; 23 | constructor Create; 24 | public 25 | function RequiredMessage(const AValue: string): THorseCoreParamConfig; overload; 26 | function RequiredMessage: string; overload; 27 | function InvalidFormatMessage(const AValue: string): THorseCoreParamConfig; overload; 28 | function InvalidFormatMessage: string; overload; 29 | function DateFormat(const AValue: string): THorseCoreParamConfig; overload; 30 | function DateFormat: string; overload; 31 | function TimeFormat(const AValue: string): THorseCoreParamConfig; overload; 32 | function TimeFormat: string; overload; 33 | function ReturnUTC(const AValue: Boolean): THorseCoreParamConfig; overload; 34 | function ReturnUTC: Boolean; overload; 35 | function TrueValue(const AValue: string): THorseCoreParamConfig; overload; 36 | function TrueValue: string; overload; 37 | function CheckLhsBrackets(const AValue: Boolean): THorseCoreParamConfig; overload; 38 | function CheckLhsBrackets: Boolean; overload; 39 | class function GetInstance: THorseCoreParamConfig; 40 | class destructor UnInitialize; 41 | end; 42 | 43 | implementation 44 | 45 | uses 46 | {$IF DEFINED(FPC)} 47 | SysUtils; 48 | {$ELSE} 49 | System.SysUtils; 50 | {$ENDIF} 51 | 52 | constructor THorseCoreParamConfig.Create; 53 | begin 54 | FReturnUTC := True; 55 | FDateFormat := 'yyyy-MM-dd'; 56 | FTimeFormat := 'hh:mm:ss'; 57 | FTrueValue := 'true'; 58 | FRequiredMessage := 'The %s param is required.'; 59 | FInvalidFormatMessage := 'The %0:s param ''%1:s'' is not valid a %2:s type.'; 60 | FCheckLhsBrackets := False; 61 | end; 62 | 63 | function THorseCoreParamConfig.DateFormat(const AValue: string): THorseCoreParamConfig; 64 | begin 65 | Result := Self; 66 | FDateFormat := AValue; 67 | end; 68 | 69 | function THorseCoreParamConfig.DateFormat: string; 70 | begin 71 | Result := FDateFormat; 72 | end; 73 | 74 | class function THorseCoreParamConfig.GetInstance: THorseCoreParamConfig; 75 | begin 76 | if not Assigned(FInstance) then 77 | FInstance := THorseCoreParamConfig.Create; 78 | Result := FInstance; 79 | end; 80 | 81 | function THorseCoreParamConfig.InvalidFormatMessage: string; 82 | begin 83 | Result := FInvalidFormatMessage; 84 | end; 85 | 86 | function THorseCoreParamConfig.InvalidFormatMessage(const AValue: string): THorseCoreParamConfig; 87 | begin 88 | Result := Self; 89 | FInvalidFormatMessage := AValue; 90 | end; 91 | 92 | function THorseCoreParamConfig.RequiredMessage(const AValue: string): THorseCoreParamConfig; 93 | begin 94 | Result := Self; 95 | FRequiredMessage := AValue; 96 | end; 97 | 98 | function THorseCoreParamConfig.RequiredMessage: string; 99 | begin 100 | Result := FRequiredMessage; 101 | end; 102 | 103 | function THorseCoreParamConfig.ReturnUTC(const AValue: Boolean): THorseCoreParamConfig; 104 | begin 105 | Result := Self; 106 | FReturnUTC := AValue; 107 | end; 108 | 109 | function THorseCoreParamConfig.ReturnUTC: Boolean; 110 | begin 111 | Result := FReturnUTC; 112 | end; 113 | 114 | function THorseCoreParamConfig.TimeFormat: string; 115 | begin 116 | Result := FTimeFormat; 117 | end; 118 | 119 | function THorseCoreParamConfig.TimeFormat(const AValue: string): THorseCoreParamConfig; 120 | begin 121 | Result := Self; 122 | FTimeFormat := AValue; 123 | end; 124 | 125 | function THorseCoreParamConfig.TrueValue(const AValue: string): THorseCoreParamConfig; 126 | begin 127 | Result := Self; 128 | FTrueValue := AValue; 129 | end; 130 | 131 | function THorseCoreParamConfig.TrueValue: string; 132 | begin 133 | Result := FTrueValue; 134 | end; 135 | 136 | function THorseCoreParamConfig.CheckLhsBrackets(const AValue: Boolean 137 | ): THorseCoreParamConfig; 138 | begin 139 | Result := Self; 140 | FCheckLhsBrackets := AValue; 141 | end; 142 | 143 | function THorseCoreParamConfig.CheckLhsBrackets: Boolean; 144 | begin 145 | Result := FCheckLhsBrackets; 146 | end; 147 | 148 | class destructor THorseCoreParamConfig.UnInitialize; 149 | begin 150 | if Assigned(FInstance) then 151 | FreeAndNil(FInstance); 152 | end; 153 | 154 | end. 155 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.FPC.FastCGI.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.FPC.FastCGI; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | {$IF DEFINED(FPC) AND DEFINED(HORSE_FCGI)} 10 | uses SysUtils, Classes, fpFCGI, httpdefs, fpHTTP, Horse.Provider.Abstract, Horse.Constants, Horse.Proc; 11 | 12 | type 13 | THorseProvider = class(THorseProviderAbstract) 14 | private 15 | class var FPort: Integer; 16 | class var FHost: string; 17 | class var FRunning: Boolean; 18 | class var FFastCGIApplication: TFCGIApplication; 19 | class function GetDefaultFastCGIApplication: TFCGIApplication; 20 | class function FastCGIApplicationIsNil: Boolean; 21 | class procedure SetPort(const AValue: Integer); static; 22 | class procedure SetHost(const AValue: string); static; 23 | class function GetPort: Integer; static; 24 | class function GetDefaultPort: Integer; static; 25 | class function GetDefaultHost: string; static; 26 | class function GetHost: string; static; 27 | class procedure InternalListen; virtual; 28 | class procedure DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 29 | public 30 | class property Host: string read GetHost write SetHost; 31 | class property Port: Integer read GetPort write SetPort; 32 | class procedure Listen; overload; override; 33 | class procedure Listen(const APort: Integer; const AHost: string = '0.0.0.0'; const ACallback: TProc = nil); reintroduce; overload; static; 34 | class procedure Listen(const APort: Integer; const ACallback: TProc); reintroduce; overload; static; 35 | class procedure Listen(const AHost: string; const ACallback: TProc = nil); reintroduce; overload; static; 36 | class procedure Listen(const ACallback: TProc); reintroduce; overload; static; 37 | end; 38 | {$ENDIF} 39 | 40 | implementation 41 | 42 | {$IF DEFINED(FPC) AND DEFINED(HORSE_FCGI)} 43 | uses Horse.WebModule; 44 | 45 | class function THorseProvider.GetDefaultFastCGIApplication: TFCGIApplication; 46 | begin 47 | if FastCGIApplicationIsNil then 48 | FFastCGIApplication := Application; 49 | Result := FFastCGIApplication; 50 | end; 51 | 52 | class function THorseProvider.FastCGIApplicationIsNil: Boolean; 53 | begin 54 | Result := FFastCGIApplication = nil; 55 | end; 56 | 57 | class function THorseProvider.GetDefaultHost: string; 58 | begin 59 | Result := DEFAULT_HOST; 60 | end; 61 | 62 | class function THorseProvider.GetDefaultPort: Integer; 63 | begin 64 | Result := -1; 65 | end; 66 | 67 | class function THorseProvider.GetHost: string; 68 | begin 69 | Result := FHost; 70 | end; 71 | 72 | class function THorseProvider.GetPort: Integer; 73 | begin 74 | Result := FPort; 75 | end; 76 | 77 | class procedure THorseProvider.InternalListen; 78 | var 79 | LFastCGIApplication: TFCGIApplication; 80 | begin 81 | inherited; 82 | if FHost.IsEmpty then 83 | FHost := GetDefaultHost; 84 | LFastCGIApplication := GetDefaultFastCGIApplication; 85 | LFastCGIApplication.AllowDefaultModule := True; 86 | LFastCGIApplication.OnGetModule := DoGetModule; 87 | LFastCGIApplication.Port := FPort; 88 | LFastCGIApplication.LegacyRouting := True; 89 | LFastCGIApplication.Address := FHost; 90 | LFastCGIApplication.Initialize; 91 | FRunning := True; 92 | DoOnListen; 93 | LFastCGIApplication.Run; 94 | end; 95 | 96 | class procedure THorseProvider.DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 97 | begin 98 | ModuleClass := THorseWebModule; 99 | end; 100 | 101 | class procedure THorseProvider.Listen; 102 | begin 103 | InternalListen;; 104 | end; 105 | 106 | class procedure THorseProvider.Listen(const APort: Integer; const AHost: string; const ACallback: TProc); 107 | begin 108 | SetPort(APort); 109 | SetHost(AHost); 110 | SetOnListen(ACallback); 111 | InternalListen; 112 | end; 113 | 114 | class procedure THorseProvider.Listen(const AHost: string; const ACallback: TProc); 115 | begin 116 | Listen(FPort, AHost, ACallback); 117 | end; 118 | 119 | class procedure THorseProvider.Listen(const ACallback: TProc); 120 | begin 121 | Listen(FPort, FHost, ACallback); 122 | end; 123 | 124 | class procedure THorseProvider.Listen(const APort: Integer; const ACallback: TProc); 125 | begin 126 | Listen(APort, FHost, ACallback); 127 | end; 128 | 129 | class procedure THorseProvider.SetHost(const AValue: string); 130 | begin 131 | FHost := AValue; 132 | end; 133 | 134 | class procedure THorseProvider.SetPort(const AValue: Integer); 135 | begin 136 | FPort := AValue; 137 | end; 138 | {$ENDIF} 139 | 140 | end. 141 | -------------------------------------------------------------------------------- /Source/FRExport.Interfaces.Providers.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | { } 3 | { FRExport } 4 | { } 5 | { Copyright (C) Antônio José Medeiros Schneider Júnior } 6 | { } 7 | { https://github.com/antoniojmsjr/FastReportExport } 8 | { } 9 | { } 10 | {******************************************************************************} 11 | { } 12 | { Licensed under the Apache License, Version 2.0 (the "License"); } 13 | { you may not use this file except in compliance with the License. } 14 | { You may obtain a copy of the License at } 15 | { } 16 | { http://www.apache.org/licenses/LICENSE-2.0 } 17 | { } 18 | { Unless required by applicable law or agreed to in writing, software } 19 | { distributed under the License is distributed on an "AS IS" BASIS, } 20 | { WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } 21 | { See the License for the specific language governing permissions and } 22 | { limitations under the License. } 23 | { } 24 | {******************************************************************************} 25 | unit FRExport.Interfaces.Providers; 26 | 27 | interface 28 | 29 | uses 30 | System.Classes, frxClass, frxExportPDF, frxExportHTML, frxExportImage, 31 | frxExportCSV, frxExportRTF, frxExportXLS, frxExportXLSX, frxExportDOCX; 32 | 33 | type 34 | 35 | IFRExportProvider = interface 36 | ['{801C408B-8B7F-4288-AE41-42E836F0EACD}'] 37 | function GetfrxCustomExportFilter: TfrxCustomExportFilter; 38 | function GetName: string; 39 | function GetStream: TStream; 40 | 41 | property Stream: TStream read GetStream; 42 | property Name: string read GetName; 43 | end; 44 | 45 | IFRExportPDF = interface(IFRExportProvider) 46 | ['{B706F9B7-371C-4B77-86E7-921CAFAEFABA}'] 47 | function GetfrxPDF: TfrxPDFExport; 48 | 49 | property frxPDF: TfrxPDFExport read GetfrxPDF; 50 | end; 51 | 52 | IFRExportHTML = interface(IFRExportProvider) 53 | ['{227479C3-5BDF-458A-AE20-8340E54820C7}'] 54 | function GetfrxHTML: TfrxHTMLExport; 55 | 56 | property frxHTML: TfrxHTMLExport read GetfrxHTML; 57 | end; 58 | 59 | IFRExportPNG = interface(IFRExportProvider) 60 | ['{275CE260-3C9E-4ECB-A31C-E5103AE5E4C5}'] 61 | function GetfrxPNG: TfrxPNGExport; 62 | 63 | property frxPNG: TfrxPNGExport read GetfrxPNG; 64 | end; 65 | 66 | IFRExportCSV = interface(IFRExportProvider) 67 | ['{54A9E434-16E6-49B5-86D9-6E157FBE810B}'] 68 | function GetfrxCSV: TfrxCSVExport; 69 | 70 | property frxCSV: TfrxCSVExport read GetfrxCSV; 71 | end; 72 | 73 | IFRExportRTF = interface(IFRExportProvider) 74 | ['{831B3B9F-9F50-4FF2-9F5F-0F37F115A4D5}'] 75 | function GetfrxRTF: TfrxRTFExport; 76 | 77 | property frxRTF: TfrxRTFExport read GetfrxRTF; 78 | end; 79 | 80 | IFRExportXLS = interface(IFRExportProvider) 81 | ['{C57D4C26-656B-4159-A229-B0B795BD14D8}'] 82 | function GetfrxXLS: TfrxXLSExport; 83 | 84 | property frxXLS: TfrxXLSExport read GetfrxXLS; 85 | end; 86 | 87 | IFRExportXLSX = interface(IFRExportProvider) 88 | ['{E1185657-BDD7-4F28-836B-4CEB764D5D26}'] 89 | function GetfrxXLSX: TfrxXLSXExport; 90 | 91 | property frxXLSX: TfrxXLSXExport read GetfrxXLSX; 92 | end; 93 | 94 | IFRExportDOCX = interface(IFRExportProvider) 95 | ['{F05403B5-6E5C-4088-AE62-81F3DA8A986D}'] 96 | function GetfrxDOCX: TfrxDOCXExport; 97 | 98 | property frxDOCX: TfrxDOCXExport read GetfrxDOCX; 99 | end; 100 | 101 | IFRExportBMP = interface(IFRExportProvider) 102 | ['{2DE25CD1-ADB0-4EB4-A355-25BE4EFC816F}'] 103 | function GetfrxBMP: TfrxBMPExport; 104 | 105 | property frxBMP: TfrxBMPExport read GetfrxBMP; 106 | end; 107 | 108 | IFRExportJPEG = interface(IFRExportProvider) 109 | ['{1F1DD580-6C83-499F-861D-8BCCC8DB3198}'] 110 | function GetfrxJPEG: TfrxJPEGExport; 111 | 112 | property frxJPEG: TfrxJPEGExport read GetfrxJPEG; 113 | end; 114 | 115 | implementation 116 | 117 | end. 118 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.FPC.HTTPApplication.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.FPC.HTTPApplication; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | {$IF DEFINED(FPC)} 10 | uses SysUtils, Classes, httpdefs, fpHTTP, fphttpapp, Horse.Provider.Abstract, Horse.Constants, Horse.Proc; 11 | 12 | type 13 | THorseProvider = class(THorseProviderAbstract) 14 | private 15 | class var FPort: Integer; 16 | class var FHost: string; 17 | class var FRunning: Boolean; 18 | class var FListenQueue: Integer; 19 | class var FHTTPApplication: THTTPApplication; 20 | class function GetDefaultHTTPApplication: THTTPApplication; 21 | class function HTTPApplicationIsNil: Boolean; 22 | class procedure SetListenQueue(const AValue: Integer); static; 23 | class procedure SetPort(const AValue: Integer); static; 24 | class procedure SetHost(const AValue: string); static; 25 | class function GetListenQueue: Integer; static; 26 | class function GetPort: Integer; static; 27 | class function GetDefaultPort: Integer; static; 28 | class function GetDefaultHost: string; static; 29 | class function GetHost: string; static; 30 | class procedure InternalListen; virtual; 31 | class procedure DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 32 | public 33 | class property Host: string read GetHost write SetHost; 34 | class property Port: Integer read GetPort write SetPort; 35 | class property ListenQueue: Integer read GetListenQueue write SetListenQueue; 36 | class procedure Listen; overload; override; 37 | class procedure Listen(const APort: Integer; const AHost: string = '0.0.0.0'; const ACallback: TProc = nil); reintroduce; overload; static; 38 | class procedure Listen(const APort: Integer; const ACallback: TProc); reintroduce; overload; static; 39 | class procedure Listen(const AHost: string; const ACallback: TProc = nil); reintroduce; overload; static; 40 | class procedure Listen(const ACallback: TProc); reintroduce; overload; static; 41 | class function IsRunning: Boolean; 42 | end; 43 | {$ENDIF} 44 | 45 | implementation 46 | 47 | {$IF DEFINED(FPC)} 48 | uses Horse.WebModule; 49 | 50 | class function THorseProvider.GetDefaultHTTPApplication: THTTPApplication; 51 | begin 52 | if HTTPApplicationIsNil then 53 | FHTTPApplication := Application; 54 | Result := FHTTPApplication; 55 | end; 56 | 57 | class function THorseProvider.HTTPApplicationIsNil: Boolean; 58 | begin 59 | Result := FHTTPApplication = nil; 60 | end; 61 | 62 | class function THorseProvider.GetDefaultHost: string; 63 | begin 64 | Result := DEFAULT_HOST; 65 | end; 66 | 67 | class function THorseProvider.GetDefaultPort: Integer; 68 | begin 69 | Result := DEFAULT_PORT; 70 | end; 71 | 72 | class function THorseProvider.GetHost: string; 73 | begin 74 | Result := FHost; 75 | end; 76 | 77 | class function THorseProvider.GetListenQueue: Integer; 78 | begin 79 | Result := FListenQueue; 80 | end; 81 | 82 | class function THorseProvider.GetPort: Integer; 83 | begin 84 | Result := FPort; 85 | end; 86 | 87 | class procedure THorseProvider.InternalListen; 88 | var 89 | LHTTPApplication: THTTPApplication; 90 | begin 91 | inherited; 92 | if FPort <= 0 then 93 | FPort := GetDefaultPort; 94 | if FHost.IsEmpty then 95 | FHost := GetDefaultHost; 96 | if FListenQueue = 0 then 97 | FListenQueue := 15; 98 | LHTTPApplication := GetDefaultHTTPApplication; 99 | LHTTPApplication.AllowDefaultModule := True; 100 | LHTTPApplication.OnGetModule := DoGetModule; 101 | LHTTPApplication.Threaded := True; 102 | LHTTPApplication.QueueSize := FListenQueue; 103 | LHTTPApplication.Port := FPort; 104 | LHTTPApplication.LegacyRouting := True; 105 | LHTTPApplication.Address := FHost; 106 | LHTTPApplication.Initialize; 107 | FRunning := True; 108 | DoOnListen; 109 | LHTTPApplication.Run; 110 | end; 111 | 112 | class procedure THorseProvider.DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 113 | begin 114 | ModuleClass := THorseWebModule; 115 | end; 116 | 117 | class function THorseProvider.IsRunning: Boolean; 118 | begin 119 | Result := FRunning; 120 | end; 121 | 122 | class procedure THorseProvider.Listen; 123 | begin 124 | InternalListen;; 125 | end; 126 | 127 | class procedure THorseProvider.Listen(const APort: Integer; const AHost: string; const ACallback: TProc); 128 | begin 129 | SetPort(APort); 130 | SetHost(AHost); 131 | SetOnListen(ACallback); 132 | InternalListen; 133 | end; 134 | 135 | class procedure THorseProvider.Listen(const AHost: string; const ACallback: TProc); 136 | begin 137 | Listen(FPort, AHost, ACallback); 138 | end; 139 | 140 | class procedure THorseProvider.Listen(const ACallback: TProc); 141 | begin 142 | Listen(FPort, FHost, ACallback); 143 | end; 144 | 145 | class procedure THorseProvider.Listen(const APort: Integer; const ACallback: TProc); 146 | begin 147 | Listen(APort, FHost, ACallback); 148 | end; 149 | 150 | class procedure THorseProvider.SetHost(const AValue: string); 151 | begin 152 | FHost := AValue; 153 | end; 154 | 155 | class procedure THorseProvider.SetListenQueue(const AValue: Integer); 156 | begin 157 | FListenQueue := AValue; 158 | end; 159 | 160 | class procedure THorseProvider.SetPort(const AValue: Integer); 161 | begin 162 | FPort := AValue; 163 | end; 164 | {$ENDIF} 165 | 166 | end. 167 | -------------------------------------------------------------------------------- /Samples/Utils/Data.pas: -------------------------------------------------------------------------------- 1 | unit Data; 2 | 3 | interface 4 | 5 | uses 6 | FireDAC.Comp.Client, System.SysUtils; 7 | 8 | type 9 | TData = class 10 | private 11 | { private declarations } 12 | protected 13 | { protected declarations } 14 | public 15 | { public declarations } 16 | class procedure QryEstadosBrasil(pFDConnection: TFDConnection; var pQuery: TFDQuery); 17 | class procedure QryMunicipioEstado(pFDConnection: TFDConnection; var pQuery: TFDQuery); 18 | class procedure QryMunicipioRegiao(pFDConnection: TFDConnection; var pQuery: TFDQuery); 19 | class procedure QryEstadoRegiao(pFDConnection: TFDConnection; var pQuery: TFDQuery); 20 | class procedure QryMunicipios(pFDConnection: TFDConnection; var pQuery: TFDQuery; 21 | const pEstadoID: Integer = 0); 22 | end; 23 | 24 | implementation 25 | 26 | uses 27 | Utils; 28 | 29 | { TData } 30 | 31 | class procedure TData.QryEstadoRegiao(pFDConnection: TFDConnection; var pQuery: TFDQuery); 32 | var 33 | lSQL: TStringBuilder; 34 | lError: string; 35 | begin 36 | lSQL := nil; 37 | try 38 | pQuery := TFDQuery.Create(pFDConnection); 39 | pQuery.Connection := pFDConnection; 40 | 41 | lSQL := TStringBuilder.Create; 42 | lSQL.Append('SELECT'); 43 | lSQL.Append(' TB2.ID, TB2.NOME, COUNT(1) AS ESTADO_QTD '); 44 | lSQL.Append('FROM'); 45 | lSQL.Append(' ESTADO TB1 '); 46 | lSQL.Append('INNER JOIN'); 47 | lSQL.Append(' REGIAO TB2 '); 48 | lSQL.Append('ON'); 49 | lSQL.Append(' TB1.REGIAO_ID = TB2.ID '); 50 | lSQL.Append('GROUP BY'); 51 | lSQL.Append(' TB2.ID, TB2.NOME'); 52 | 53 | if not TUtils.QueryOpen(pQuery, lSQL.ToString, lError) then 54 | raise Exception.CreateFmt('Erro consulta - QryEstadoRegiao: %s', [lError]); 55 | finally 56 | lSQL.Free; 57 | end; 58 | end; 59 | 60 | class procedure TData.QryEstadosBrasil(pFDConnection: TFDConnection; var pQuery: TFDQuery); 61 | var 62 | lSQL: TStringBuilder; 63 | lError: string; 64 | begin 65 | lSQL := nil; 66 | try 67 | pQuery := TFDQuery.Create(pFDConnection); 68 | pQuery.Connection := pFDConnection; 69 | 70 | lSQL := TStringBuilder.Create; 71 | lSQL.Append('SELECT'); 72 | lSQL.Append(' TB1.ID AS ESTADO_ID, TB1.NOME AS ESTADO_NOME,'); 73 | lSQL.Append(' TB2.ID AS REGIAO_ID, TB2.NOME AS REGIAO_NOME '); 74 | lSQL.Append('FROM'); 75 | lSQL.Append(' ESTADO TB1 '); 76 | lSQL.Append('INNER JOIN'); 77 | lSQL.Append(' REGIAO TB2 '); 78 | lSQL.Append('ON'); 79 | lSQL.Append(' TB1.REGIAO_ID = TB2.ID '); 80 | lSQL.Append('ORDER BY'); 81 | lSQL.Append(' TB2.ID, TB1.NOME ASC'); 82 | 83 | if not TUtils.QueryOpen(pQuery, lSQL.ToString, lError) then 84 | raise Exception.CreateFmt('Erro consulta - QryEstadosBrasil: %s', [lError]); 85 | finally 86 | lSQL.Free; 87 | end; 88 | end; 89 | 90 | class procedure TData.QryMunicipioEstado(pFDConnection: TFDConnection; var pQuery: TFDQuery); 91 | var 92 | lSQL: TStringBuilder; 93 | lError: string; 94 | begin 95 | lSQL := nil; 96 | try 97 | pQuery := TFDQuery.Create(pFDConnection); 98 | pQuery.Connection := pFDConnection; 99 | 100 | lSQL := TStringBuilder.Create; 101 | lSQL.Append('SELECT'); 102 | lSQL.Append(' ESTADO_ID, ESTADO_NOME, COUNT(1) AS MUNICIPIO_QTD '); 103 | lSQL.Append('FROM'); 104 | lSQL.Append(' VW_LOCALIDADES '); 105 | lSQL.Append('GROUP BY'); 106 | lSQL.Append(' ESTADO_ID, ESTADO_NOME'); 107 | 108 | if not TUtils.QueryOpen(pQuery, lSQL.ToString, lError) then 109 | raise Exception.CreateFmt('Erro consulta - QryMunicipioEstado: %s', [lError]); 110 | finally 111 | lSQL.Free; 112 | end; 113 | end; 114 | 115 | class procedure TData.QryMunicipioRegiao(pFDConnection: TFDConnection; var pQuery: TFDQuery); 116 | var 117 | lSQL: TStringBuilder; 118 | lError: string; 119 | begin 120 | lSQL := nil; 121 | try 122 | pQuery := TFDQuery.Create(pFDConnection); 123 | pQuery.Connection := pFDConnection; 124 | 125 | lSQL := TStringBuilder.Create; 126 | lSQL.Append('SELECT'); 127 | lSQL.Append(' REGIAO_ID, REGIAO_NOME, COUNT(1) AS MUNICIPIO_QTD '); 128 | lSQL.Append('FROM'); 129 | lSQL.Append(' VW_LOCALIDADES '); 130 | lSQL.Append('GROUP BY'); 131 | lSQL.Append(' REGIAO_ID, REGIAO_NOME'); 132 | 133 | if not TUtils.QueryOpen(pQuery, lSQL.ToString, lError) then 134 | raise Exception.CreateFmt('Erro consulta - QryMunicipioRegiao: %s', [lError]); 135 | finally 136 | lSQL.Free; 137 | end; 138 | end; 139 | 140 | class procedure TData.QryMunicipios(pFDConnection: TFDConnection; 141 | var pQuery: TFDQuery; const pEstadoID: Integer); 142 | var 143 | lSQL: TStringBuilder; 144 | lError: string; 145 | begin 146 | lSQL := nil; 147 | try 148 | pQuery := TFDQuery.Create(pFDConnection); 149 | pQuery.Connection := pFDConnection; 150 | 151 | lSQL := TStringBuilder.Create; 152 | lSQL.Append('SELECT'); 153 | lSQL.Append(' MUNICIPIO_ID, MUNICIPIO_NOME, '); 154 | lSQL.Append(' ESTADO_ID, ESTADO_NOME, '); 155 | lSQL.Append(' REGIAO_ID, REGIAO_NOME '); 156 | lSQL.Append('FROM '); 157 | lSQL.Append(' VW_LOCALIDADES '); 158 | if (pEstadoID > 0) then 159 | lSQL.Append(Format('WHERE ESTADO_ID = %d ', [pEstadoID])); 160 | lSQL.Append('ORDER BY'); 161 | lSQL.Append(' REGIAO_ID, ESTADO_NOME, MUNICIPIO_NOME'); 162 | 163 | if not TUtils.QueryOpen(pQuery, lSQL.ToString, lError) then 164 | raise Exception.CreateFmt('Erro consulta - QryMunicipios: %s', [lError]); 165 | finally 166 | lSQL.Free; 167 | end; 168 | end; 169 | 170 | end. 171 | -------------------------------------------------------------------------------- /Source/FRExport.Types.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | { } 3 | { FRExport } 4 | { } 5 | { Copyright (C) Antônio José Medeiros Schneider Júnior } 6 | { } 7 | { https://github.com/antoniojmsjr/FastReportExport } 8 | { } 9 | { } 10 | {******************************************************************************} 11 | { } 12 | { Licensed under the Apache License, Version 2.0 (the "License"); } 13 | { you may not use this file except in compliance with the License. } 14 | { You may obtain a copy of the License at } 15 | { } 16 | { http://www.apache.org/licenses/LICENSE-2.0 } 17 | { } 18 | { Unless required by applicable law or agreed to in writing, software } 19 | { distributed under the License is distributed on an "AS IS" BASIS, } 20 | { WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. } 21 | { See the License for the specific language governing permissions and } 22 | { limitations under the License. } 23 | { } 24 | {******************************************************************************} 25 | unit FRExport.Types; 26 | 27 | interface 28 | 29 | uses 30 | frxClass, System.Classes, System.SysUtils; 31 | 32 | type 33 | TFRExportReportCallback = reference to procedure(frxReport: TfrxReport); 34 | 35 | EFRExport = class(Exception) 36 | private 37 | { private declarations } 38 | protected 39 | { protected declarations } 40 | FMessage: string; 41 | public 42 | { public declarations } 43 | end; 44 | 45 | EFRExportFileReport = class(EFRExport) 46 | private 47 | { private declarations } 48 | FFileName: string; 49 | protected 50 | { protected declarations } 51 | public 52 | { public declarations } 53 | constructor Create(const pFileName: string; const pMessage: string); 54 | function ToString: string; override; 55 | property FileName: string read FFileName; 56 | end; 57 | 58 | EFRExportProvider = class(EFRExport) 59 | private 60 | { private declarations } 61 | FProvider: string; 62 | protected 63 | { protected declarations } 64 | public 65 | { public declarations } 66 | constructor Create(const pProvider: string; const pMessage: string); 67 | function ToString: string; override; 68 | property Provider: string read FProvider; 69 | end; 70 | 71 | EFRExportPrepareReport = class(EFRExport) 72 | private 73 | { private declarations } 74 | FMessages: TStrings; 75 | protected 76 | { protected declarations } 77 | public 78 | { public declarations } 79 | constructor Create(const pMessages: TStrings); 80 | destructor Destroy; override; 81 | function ToString: string; override; 82 | property Messages: TStrings read FMessages; 83 | end; 84 | 85 | implementation 86 | 87 | {$REGION 'EFRExportProvider'} 88 | constructor EFRExportProvider.Create(const pProvider: string; 89 | const pMessage: string); 90 | begin 91 | inherited Create('See ToString.'); 92 | FProvider := pProvider; 93 | FMessage := pMessage; 94 | end; 95 | 96 | function EFRExportProvider.ToString: string; 97 | begin 98 | Result := EmptyStr; 99 | Result := Concat(Result, 'Export Providers', sLineBreak, sLineBreak); 100 | Result := Concat(Result, 'Provider: ', FProvider, sLineBreak); 101 | Result := Concat(Result, 'Message: ', FMessage); 102 | end; 103 | {$ENDREGION} 104 | 105 | {$REGION 'EFRExportPrepareReport'} 106 | constructor EFRExportPrepareReport.Create(const pMessages: TStrings); 107 | begin 108 | inherited Create('See ToString.'); 109 | 110 | FMessages := TStringList.Create; 111 | FMessages.AddStrings(pMessages); 112 | end; 113 | 114 | destructor EFRExportPrepareReport.Destroy; 115 | begin 116 | FMessages.Free; 117 | inherited Destroy; 118 | end; 119 | 120 | function EFRExportPrepareReport.ToString: string; 121 | var 122 | I: Integer; 123 | begin 124 | Result := EmptyStr; 125 | Result := Concat(Result, 'Prepare Report', sLineBreak, sLineBreak); 126 | for I := 0 to Pred(FMessages.Count) do 127 | Result := Concat(Result, '* ', FMessages.Strings[I], sLineBreak); 128 | end; 129 | {$ENDREGION} 130 | 131 | {$REGION 'EFRExportFileReport'} 132 | constructor EFRExportFileReport.Create(const pFileName: string; 133 | const pMessage: string); 134 | begin 135 | inherited Create('See ToString.'); 136 | FFileName := pFileName; 137 | FMessage := pMessage; 138 | end; 139 | 140 | function EFRExportFileReport.ToString: string; 141 | begin 142 | Result := EmptyStr; 143 | Result := Concat(Result, 'Export File', sLineBreak, sLineBreak); 144 | Result := Concat(Result, 'File: ', FFileName, sLineBreak); 145 | Result := Concat(Result, 'Message: ', FMessage); 146 | end; 147 | {$ENDREGION} 148 | 149 | end. 150 | -------------------------------------------------------------------------------- /Samples/Utils/Utils.pas: -------------------------------------------------------------------------------- 1 | unit Utils; 2 | 3 | interface 4 | 5 | uses 6 | System.Classes, System.SysUtils, Winapi.Windows, 7 | FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf, 8 | FireDAC.Phys.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async, 9 | FireDAC.Phys, FireDAC.VCLUI.Wait, Data.DB, FireDAC.Comp.Client, 10 | FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, FireDAC.DApt, 11 | FireDAC.Comp.DataSet, 12 | 13 | FireDAC.Phys.FBDef, FireDAC.Phys.IBBase, FireDAC.Phys.FB, FireDAC.Phys.IBWrapper; 14 | 15 | type 16 | 17 | TUtils = class sealed 18 | private 19 | { private declarations } 20 | protected 21 | { protected declarations } 22 | public 23 | { public declarations } 24 | class function PathAppFileDB: string; 25 | class function PathAppFileReport: string; 26 | class function PathApp: string; 27 | class function PathAppFile: string; 28 | class function GetHTML(const pHost: string; const pFilePDF: string; const pFileHTML: string; const pFilePNG: string): string; 29 | class function ConnectDB(const pServer: string; const pDataBase: string; 30 | pFDConnection: TFDConnection; out poError: string): Boolean; 31 | class function QueryOpen(pQuery: TFDQuery; const pSQL: string; out poError: string): Boolean; static; 32 | end; 33 | 34 | implementation 35 | 36 | { TUtils } 37 | 38 | class function TUtils.ConnectDB(const pServer: string; const pDataBase: string; 39 | pFDConnection: TFDConnection; out poError: string): Boolean; 40 | var 41 | lFBConnectionDefParams: TFDPhysFBConnectionDefParams; // FIREBIRD CONNECTION PARAMS 42 | begin 43 | Result := False; 44 | 45 | lFBConnectionDefParams := TFDPhysFBConnectionDefParams(pFDConnection.Params); 46 | lFBConnectionDefParams.DriverID := 'FB'; 47 | lFBConnectionDefParams.Server := pServer; 48 | lFBConnectionDefParams.Database := pDataBase; 49 | lFBConnectionDefParams.UserName := 'SYSDBA'; 50 | lFBConnectionDefParams.Password := 'masterkey'; 51 | lFBConnectionDefParams.Protocol := TIBProtocol.ipLocal; 52 | 53 | pFDConnection.FetchOptions.Mode := TFDFetchMode.fmAll; //fmAll 54 | pFDConnection.ResourceOptions.AutoConnect := False; 55 | pFDConnection.ResourceOptions.SilentMode := True; 56 | 57 | try 58 | pFDConnection.Open; 59 | Result := True; 60 | except 61 | on E: Exception do 62 | poError := E.Message; 63 | end; 64 | end; 65 | 66 | class function TUtils.QueryOpen(pQuery: TFDQuery; 67 | const pSQL: string; out poError: string): Boolean; 68 | begin 69 | Result := False; 70 | try 71 | pQuery.Close; 72 | pQuery.SQL.Clear; 73 | pQuery.SQL.Add(pSQL); 74 | pQuery.Open; 75 | Result := True; 76 | except 77 | on E: Exception do 78 | poError := E.Message; 79 | end; 80 | end; 81 | 82 | class function TUtils.GetHTML(const pHost: string; const pFilePDF: string; 83 | const pFileHTML: string; const pFilePNG: string): string; 84 | var 85 | lHTML: TStrings; 86 | lFileName: string; 87 | lLink: string; 88 | begin 89 | lHTML := TStringList.Create; 90 | 91 | try 92 | lHTML.Add(''); 93 | lHTML.Add(''); 94 | lHTML.Add(''); 95 | lHTML.Add('View Files'); 96 | lHTML.Add(''); 97 | lHTML.Add(''); 98 | lHTML.Add('
'); 99 | 100 | lFileName := ExtractFileName(pFilePDF); 101 | lLink := Format('%s/%s', [pHost, lFileName]); 102 | lHTML.Add(''+lLink+'

'); 103 | 104 | lFileName := ExtractFileName(pFileHTML); 105 | lLink := Format('%s/%s', [pHost, lFileName]); 106 | lHTML.Add(''+lLink+'

'); 107 | 108 | lFileName := ExtractFileName(pFilePNG); 109 | lLink := Format('%s/%s', [pHost, lFileName]); 110 | lHTML.Add(''+lLink+'

'); 111 | 112 | lHTML.Add('
'); 113 | lHTML.Add(''); 114 | lHTML.Add(''); 115 | 116 | Result := lHTML.Text; 117 | finally 118 | lHTML.Free; 119 | end; 120 | end; 121 | 122 | class function TUtils.PathApp: string; 123 | begin 124 | Result := IncludeTrailingPathDelimiter(ExtractFilePath(PathAppFile)); 125 | end; 126 | 127 | class function TUtils.PathAppFileDB: string; 128 | var 129 | lPathApp: string; 130 | lPos: Integer; 131 | begin 132 | lPathApp := Self.PathApp; 133 | lPos := Pos('fastreportexport', LowerCase(lPathApp)); 134 | lPathApp := IncludeTrailingPathDelimiter(Copy(lPathApp, 1, (lPos + Length('FastReportExport')))); 135 | Result := lPathApp + 'Samples\DB\FAST_REPORT_EXPORT.FDB'; 136 | end; 137 | 138 | class function TUtils.PathAppFileReport: string; 139 | var 140 | lPathApp: string; 141 | lPos: Integer; 142 | begin 143 | lPathApp := Self.PathApp; 144 | lPos := Pos('fastreportexport', LowerCase(lPathApp)); 145 | lPathApp := IncludeTrailingPathDelimiter(Copy(lPathApp, 1, (lPos + Length('FastReportExport')))); 146 | Result := lPathApp + 'Samples\Report\rptLocalidadesIBGE.fr3'; 147 | end; 148 | 149 | class function TUtils.PathAppFile: string; 150 | var 151 | lFileName: array[0..MAX_PATH] of Char; 152 | lReturn: Cardinal; 153 | begin 154 | 155 | //DELPHI PACKAGE 156 | if ModuleIsPackage then begin 157 | Result := ParamStr(0); 158 | end 159 | else //EXE/DLL 160 | begin 161 | FillChar(lFileName, SizeOf(lFileName), #0); 162 | lReturn := GetModuleFileName(HInstance, lFileName, MAX_PATH); 163 | 164 | if (lReturn > 0) then 165 | Result := string(lFileName) 166 | else 167 | raise Exception.Create(SysErrorMessage(GetLastError)); 168 | end; 169 | 170 | //IIS 171 | if Result.StartsWith('\\?\') then 172 | Delete(Result, 1, 4); 173 | end; 174 | 175 | end. 176 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.RouterTree.NextCaller.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.RouterTree.NextCaller; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Generics.Collections, fpHTTP, httpprotocol, 12 | {$ELSE} 13 | System.NetEncoding, System.SysUtils, Web.HTTPApp, System.Generics.Collections, 14 | {$ENDIF} 15 | Horse.Commons, Horse.Request, Horse.Response, Horse.Callback; 16 | 17 | type 18 | TNextCaller = class 19 | private 20 | FIndex: Integer; 21 | FIndexCallback: Integer; 22 | FPath: TQueue; 23 | FHTTPType: TMethodType; 24 | FRequest: THorseRequest; 25 | FResponse: THorseResponse; 26 | FMiddleware: TList; 27 | FCallBack: TObjectDictionary>; 28 | FCallNextPath: TCallNextPath; 29 | FIsGroup: Boolean; 30 | FTag: string; 31 | FIsRegex: Boolean; 32 | FFound: ^Boolean; 33 | public 34 | function Init: TNextCaller; 35 | function SetCallback(const ACallback: TObjectDictionary>): TNextCaller; 36 | function SetPath(const APath: TQueue): TNextCaller; 37 | function SetHTTPType(const AHTTPType: TMethodType): TNextCaller; 38 | function SetRequest(const ARequest: THorseRequest): TNextCaller; 39 | function SetResponse(const AResponse: THorseResponse): TNextCaller; 40 | function SetIsGroup(const AIsGroup: Boolean): TNextCaller; 41 | function SetMiddleware(const AMiddleware: TList): TNextCaller; 42 | function SetTag(const ATag: string): TNextCaller; 43 | function SetIsRegex(const AIsRegex: Boolean): TNextCaller; 44 | function SetOnCallNextPath(const ACallNextPath: TCallNextPath): TNextCaller; 45 | function SetFound(var AFound: Boolean): TNextCaller; 46 | procedure Next; 47 | end; 48 | 49 | implementation 50 | 51 | uses Horse.Exception, Horse.Exception.Interrupted; 52 | 53 | function TNextCaller.Init: TNextCaller; 54 | var 55 | LCurrent: string; 56 | begin 57 | Result := Self; 58 | if not FIsGroup then 59 | LCurrent := FPath.Dequeue; 60 | FIndex := -1; 61 | FIndexCallback := -1; 62 | if FIsRegex then 63 | FRequest.Params.Dictionary.Add(FTag, {$IF DEFINED(FPC)}HTTPDecode(LCurrent){$ELSE}TNetEncoding.URL.Decode(LCurrent){$ENDIF}); 64 | end; 65 | 66 | procedure TNextCaller.Next; 67 | var 68 | LCallback: TList; 69 | begin 70 | inc(FIndex); 71 | if (FMiddleware.Count > FIndex) then 72 | begin 73 | FFound^ := True; 74 | Self.FMiddleware.Items[FIndex](FRequest, FResponse, Next); 75 | if (FMiddleware.Count > FIndex) then 76 | Next; 77 | end 78 | else 79 | if (FPath.Count = 0) and assigned(FCallBack) then 80 | begin 81 | inc(FIndexCallback); 82 | if FCallBack.TryGetValue(FHTTPType, LCallback) then 83 | begin 84 | if (LCallback.Count > FIndexCallback) then 85 | begin 86 | try 87 | FFound^ := True; 88 | LCallback.Items[FIndexCallback](FRequest, FResponse, Next); 89 | except 90 | on E: Exception do 91 | begin 92 | if (not(E is EHorseCallbackInterrupted)) and 93 | (not(E is EHorseException)) and 94 | (FResponse.Status < Integer(THTTPStatus.BadRequest)) 95 | then 96 | FResponse.Send('Internal Application Error').Status(THTTPStatus.InternalServerError); 97 | raise; 98 | end; 99 | end; 100 | Next; 101 | end; 102 | end 103 | else 104 | begin 105 | if FCallBack.Count > 0 then 106 | begin 107 | FFound^ := True; 108 | FResponse.Send('Method Not Allowed').Status(THTTPStatus.MethodNotAllowed); 109 | end 110 | else 111 | FResponse.Send('Not Found').Status(THTTPStatus.NotFound) 112 | end; 113 | end 114 | else 115 | FFound^ := FCallNextPath(FPath, FHTTPType, FRequest, FResponse); 116 | 117 | if not FFound^ then 118 | FResponse.Send('Not Found').Status(THTTPStatus.NotFound); 119 | end; 120 | 121 | function TNextCaller.SetCallback(const ACallback: TObjectDictionary < TMethodType, TList < THorseCallback >> ): TNextCaller; 122 | begin 123 | FCallBack := ACallback; 124 | Result := Self; 125 | end; 126 | 127 | function TNextCaller.SetFound(var AFound: Boolean): TNextCaller; 128 | begin 129 | FFound := @AFound; 130 | Result := Self; 131 | end; 132 | 133 | function TNextCaller.SetHTTPType(const AHTTPType: TMethodType): TNextCaller; 134 | begin 135 | FHTTPType := AHTTPType; 136 | Result := Self; 137 | end; 138 | 139 | function TNextCaller.SetIsGroup(const AIsGroup: Boolean): TNextCaller; 140 | begin 141 | FIsGroup := AIsGroup; 142 | Result := Self; 143 | end; 144 | 145 | function TNextCaller.SetIsRegex(const AIsRegex: Boolean): TNextCaller; 146 | begin 147 | FIsRegex := AIsRegex; 148 | Result := Self; 149 | end; 150 | 151 | function TNextCaller.SetMiddleware(const AMiddleware: TList): TNextCaller; 152 | begin 153 | FMiddleware := AMiddleware; 154 | Result := Self; 155 | end; 156 | 157 | function TNextCaller.SetOnCallNextPath(const ACallNextPath: TCallNextPath): TNextCaller; 158 | begin 159 | FCallNextPath := ACallNextPath; 160 | Result := Self; 161 | end; 162 | 163 | function TNextCaller.SetPath(const APath: TQueue): TNextCaller; 164 | begin 165 | FPath := APath; 166 | Result := Self; 167 | end; 168 | 169 | function TNextCaller.SetRequest(const ARequest: THorseRequest): TNextCaller; 170 | begin 171 | FRequest := ARequest; 172 | Result := Self; 173 | end; 174 | 175 | function TNextCaller.SetResponse(const AResponse: THorseResponse): TNextCaller; 176 | begin 177 | FResponse := AResponse; 178 | Result := Self; 179 | end; 180 | 181 | function TNextCaller.SetTag(const ATag: string): TNextCaller; 182 | begin 183 | FTag := ATag; 184 | Result := Self; 185 | end; 186 | 187 | end. 188 | -------------------------------------------------------------------------------- /FastReportExport.groupproj: -------------------------------------------------------------------------------- 1 | 2 | 3 | {6755DBF6-C824-4AB4-98C6-B52F48E13E16} 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | Default.Personality.12 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.FPC.LCL.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.FPC.LCL; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | {$IF DEFINED(HORSE_LCL)} 10 | uses SysUtils, Classes, httpdefs, fpHTTP, fphttpapp, Horse.Provider.Abstract, Horse.Constants, Horse.Proc; 11 | 12 | type 13 | 14 | { THorseProvider } 15 | 16 | THorseProvider = class(THorseProviderAbstract) 17 | private 18 | class var FPort: Integer; 19 | class var FHost: string; 20 | class var FRunning: Boolean; 21 | class var FListenQueue: Integer; 22 | class var FHTTPApplication: THTTPApplication; 23 | class function GetDefaultHTTPApplication: THTTPApplication; 24 | class function HTTPApplicationIsNil: Boolean; 25 | class procedure SetListenQueue(const AValue: Integer); static; 26 | class procedure SetPort(const AValue: Integer); static; 27 | class procedure SetHost(const AValue: string); static; 28 | class function GetListenQueue: Integer; static; 29 | class function GetPort: Integer; static; 30 | class function GetDefaultPort: Integer; static; 31 | class function GetDefaultHost: string; static; 32 | class function GetHost: string; static; 33 | class procedure InternalListen; virtual; 34 | class procedure InternalStopListen; virtual; 35 | class procedure DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 36 | public 37 | class property Host: string read GetHost write SetHost; 38 | class property Port: Integer read GetPort write SetPort; 39 | class property ListenQueue: Integer read GetListenQueue write SetListenQueue; 40 | class procedure StopListen; override; 41 | class procedure Listen; overload; override; 42 | class procedure Listen(const APort: Integer; const AHost: string = '0.0.0.0'; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 43 | class procedure Listen(const APort: Integer; const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 44 | class procedure Listen(const AHost: string; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 45 | class procedure Listen(const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 46 | class function IsRunning: Boolean; 47 | end; 48 | {$ENDIF} 49 | 50 | implementation 51 | 52 | {$IF DEFINED(HORSE_LCL)} 53 | uses Horse.WebModule; 54 | 55 | class function THorseProvider.GetDefaultHTTPApplication: THTTPApplication; 56 | begin 57 | if HTTPApplicationIsNil then 58 | FHTTPApplication := Application; 59 | Result := FHTTPApplication; 60 | end; 61 | 62 | class function THorseProvider.HTTPApplicationIsNil: Boolean; 63 | begin 64 | Result := FHTTPApplication = nil; 65 | end; 66 | 67 | class function THorseProvider.GetDefaultHost: string; 68 | begin 69 | Result := DEFAULT_HOST; 70 | end; 71 | 72 | class function THorseProvider.GetDefaultPort: Integer; 73 | begin 74 | Result := DEFAULT_PORT; 75 | end; 76 | 77 | class function THorseProvider.GetHost: string; 78 | begin 79 | Result := FHost; 80 | end; 81 | 82 | class function THorseProvider.GetListenQueue: Integer; 83 | begin 84 | Result := FListenQueue; 85 | end; 86 | 87 | class function THorseProvider.GetPort: Integer; 88 | begin 89 | Result := FPort; 90 | end; 91 | 92 | class procedure THorseProvider.InternalListen; 93 | begin 94 | inherited; 95 | if FPort <= 0 then 96 | FPort := GetDefaultPort; 97 | if FHost.IsEmpty then 98 | FHost := GetDefaultHost; 99 | if FListenQueue = 0 then 100 | FListenQueue := 15; 101 | FHTTPApplication := GetDefaultHTTPApplication; 102 | FHTTPApplication.Initialize; 103 | FHTTPApplication.AllowDefaultModule := True; 104 | FHTTPApplication.OnGetModule := DoGetModule; 105 | FHTTPApplication.Threaded := True; 106 | FHTTPApplication.QueueSize := FListenQueue; 107 | FHTTPApplication.Port := FPort; 108 | FHTTPApplication.LegacyRouting := True; 109 | FHTTPApplication.Address := FHost; 110 | FRunning := True; 111 | DoOnListen; 112 | FHTTPApplication.Run; 113 | end; 114 | 115 | class procedure THorseProvider.InternalStopListen; 116 | begin 117 | if not HTTPApplicationIsNil then 118 | begin 119 | FHTTPApplication.Terminate; 120 | DoOnStopListen; 121 | FRunning := False; 122 | end 123 | else 124 | raise Exception.Create('Horse not listen'); 125 | end; 126 | 127 | class procedure THorseProvider.DoGetModule(Sender: TObject; ARequest: TRequest; var ModuleClass: TCustomHTTPModuleClass); 128 | begin 129 | ModuleClass := THorseWebModule; 130 | end; 131 | 132 | class procedure THorseProvider.StopListen; 133 | begin 134 | InternalStopListen; 135 | end; 136 | 137 | class function THorseProvider.IsRunning: Boolean; 138 | begin 139 | Result := FRunning; 140 | end; 141 | 142 | class procedure THorseProvider.Listen; 143 | begin 144 | InternalListen;; 145 | end; 146 | 147 | class procedure THorseProvider.Listen(const APort: Integer; const AHost: string; const ACallbackListen: TProc; const ACallbackStopListen: TProc); 148 | begin 149 | SetPort(APort); 150 | SetHost(AHost); 151 | SetOnListen(ACallbackListen); 152 | SetOnStopListen(ACallbackStopListen); 153 | Listen; 154 | end; 155 | 156 | class procedure THorseProvider.Listen(const AHost: string; const ACallbackListen: TProc; const ACallbackStopListen: TProc); 157 | begin 158 | Listen(FPort, AHost, ACallbackListen, ACallbackStopListen); 159 | end; 160 | 161 | class procedure THorseProvider.Listen(const ACallbackListen: TProc; const ACallbackStopListen: TProc); 162 | begin 163 | Listen(FPort, FHost, ACallbackListen, ACallbackStopListen); 164 | end; 165 | 166 | class procedure THorseProvider.Listen(const APort: Integer; const ACallbackListen: TProc; const ACallbackStopListen: TProc); 167 | begin 168 | Listen(APort, FHost, ACallbackListen, ACallbackStopListen); 169 | end; 170 | 171 | class procedure THorseProvider.SetHost(const AValue: string); 172 | begin 173 | FHost := AValue.Trim; 174 | end; 175 | 176 | class procedure THorseProvider.SetListenQueue(const AValue: Integer); 177 | begin 178 | FListenQueue := AValue; 179 | end; 180 | 181 | class procedure THorseProvider.SetPort(const AValue: Integer); 182 | begin 183 | FPort := AValue; 184 | end; 185 | {$ENDIF} 186 | 187 | end. 188 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.Param.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.Param; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Classes, DateUtils, Generics.Collections, fpHTTP, fphttpserver, HTTPDefs, 12 | {$ELSE} 13 | System.SysUtils, System.Classes, System.DateUtils, System.Generics.Collections, 14 | {$ENDIF} 15 | Horse.Exception, Horse.Commons, Horse.Core.Param.Field; 16 | 17 | type 18 | THorseList = TDictionary; 19 | 20 | THorseCoreParam = class 21 | private 22 | FParams: THorseList; 23 | FFiles: TDictionary; 24 | FFields: TDictionary; 25 | FContent: TStrings; 26 | FRequired: Boolean; 27 | function GetItem(const AKey: string): string; 28 | function GetDictionary: THorseList; 29 | function GetCount: Integer; 30 | function GetContent: TStrings; 31 | function AsString(const AKey: string): string; 32 | procedure ClearFields; 33 | 34 | function NewField(const AKey: String): THorseCoreParamField; 35 | public 36 | function Required(const AValue: Boolean): THorseCoreParam; 37 | function Field(const AKey: string): THorseCoreParamField; 38 | function ContainsKey(const AKey: string): Boolean; 39 | function ContainsValue(const AValue: string): Boolean; 40 | function ToArray: TArray>; 41 | function TryGetValue(const AKey: string; var AValue: string): Boolean; 42 | property Content: TStrings read GetContent; 43 | property Count: Integer read GetCount; 44 | property Items[const AKey: string]: string read GetItem; default; 45 | property Dictionary: THorseList read GetDictionary; 46 | 47 | function AddStream(const AKey: string; const AContent: TStream): THorseCoreParam; 48 | constructor Create(const AParams: THorseList); 49 | destructor Destroy; override; 50 | end; 51 | 52 | implementation 53 | 54 | uses Horse.Core.Param.Config; 55 | 56 | function THorseCoreParam.ContainsKey(const AKey: string): Boolean; 57 | var 58 | LKey: string; 59 | begin 60 | Result := False; 61 | for LKey in FParams.Keys do 62 | begin 63 | if AnsiCompareText(LKey, AKey) = 0 then 64 | Exit(True); 65 | end; 66 | end; 67 | 68 | function THorseCoreParam.ContainsValue(const AValue: string): Boolean; 69 | begin 70 | Result := FParams.ContainsValue(AValue); 71 | end; 72 | 73 | constructor THorseCoreParam.Create(const AParams: THorseList); 74 | begin 75 | FParams := AParams; 76 | FRequired := False; 77 | end; 78 | 79 | destructor THorseCoreParam.Destroy; 80 | begin 81 | FParams.Free; 82 | FContent.Free; 83 | ClearFields; 84 | if Assigned(FFiles) then 85 | FFiles.Free; 86 | inherited; 87 | end; 88 | 89 | function THorseCoreParam.Field(const AKey: string): THorseCoreParamField; 90 | var 91 | LFieldName: string; 92 | begin 93 | if not Assigned(FFields) then 94 | FFields := TDictionary.Create; 95 | 96 | LFieldName := AKey.ToLower; 97 | if FFields.ContainsKey(LFieldName) then 98 | Exit(FFields.Items[LFieldName]); 99 | 100 | Result := NewField(AKey); 101 | try 102 | Result 103 | .Required(FRequired) 104 | .DateFormat(THorseCoreParamConfig.GetInstance.DateFormat) 105 | .InvalidFormatMessage(THorseCoreParamConfig.GetInstance.InvalidFormatMessage) 106 | .RequiredMessage(THorseCoreParamConfig.GetInstance.RequiredMessage) 107 | .ReturnUTC(THorseCoreParamConfig.GetInstance.ReturnUTC) 108 | .TimeFormat(THorseCoreParamConfig.GetInstance.TimeFormat) 109 | .TrueValue(THorseCoreParamConfig.GetInstance.TrueValue); 110 | 111 | FFields.AddOrSetValue(LFieldName, Result); 112 | except 113 | Result.Free; 114 | raise; 115 | end; 116 | end; 117 | 118 | function THorseCoreParam.AddStream(const AKey: string; const AContent: TStream): THorseCoreParam; 119 | begin 120 | Result := Self; 121 | if not Assigned(FFiles) then 122 | FFiles := TDictionary.Create; 123 | 124 | FFiles.AddOrSetValue(AKey, AContent); 125 | end; 126 | 127 | function THorseCoreParam.AsString(const AKey: string): string; 128 | var 129 | LKey: string; 130 | begin 131 | Result := EmptyStr; 132 | for LKey in FParams.Keys do 133 | begin 134 | if AnsiCompareText(LKey, AKey) = 0 then 135 | Exit(FParams.Items[LKey]); 136 | end; 137 | end; 138 | 139 | procedure THorseCoreParam.ClearFields; 140 | var 141 | LKey: string; 142 | begin 143 | if Assigned(FFields) then 144 | begin 145 | for LKey in FFields.Keys do 146 | FFields.Items[LKey].Free; 147 | 148 | FFields.Free; 149 | end; 150 | end; 151 | 152 | function THorseCoreParam.GetContent: TStrings; 153 | var 154 | LKey: string; 155 | begin 156 | if not Assigned(FContent) then 157 | begin 158 | FContent := TstringList.Create; 159 | for LKey in FParams.Keys do 160 | FContent.Add(Format('%s=%s', [LKey, FParams[LKey]])); 161 | end; 162 | Result := FContent; 163 | end; 164 | 165 | function THorseCoreParam.GetCount: Integer; 166 | begin 167 | Result := FParams.Count; 168 | end; 169 | 170 | function THorseCoreParam.GetItem(const AKey: string): string; 171 | var 172 | LKey: string; 173 | begin 174 | for LKey in FParams.Keys do 175 | begin 176 | if AnsiCompareText(LKey, AKey) = 0 then 177 | Exit(FParams[LKey]); 178 | end; 179 | Result := EmptyStr; 180 | end; 181 | 182 | function THorseCoreParam.NewField(const AKey: String): THorseCoreParamField; 183 | var 184 | LKey: String; 185 | begin 186 | if Assigned(FFiles) then 187 | begin 188 | for LKey in FFiles.Keys do 189 | begin 190 | if AnsiSameText(LKey, AKey) then 191 | begin 192 | Result := THorseCoreParamField.Create(FFiles.Items[LKey], AKey); 193 | Exit; 194 | end; 195 | end; 196 | end; 197 | 198 | Result := THorseCoreParamField.create(FParams, AKey); 199 | end; 200 | 201 | function THorseCoreParam.Required(const AValue: Boolean): THorseCoreParam; 202 | begin 203 | Result := Self; 204 | FRequired := AValue; 205 | end; 206 | 207 | function THorseCoreParam.GetDictionary: THorseList; 208 | begin 209 | Result := FParams; 210 | end; 211 | 212 | function THorseCoreParam.ToArray: TArray>; 213 | begin 214 | Result := FParams.ToArray; 215 | end; 216 | 217 | function THorseCoreParam.TryGetValue(const AKey: string; var AValue: string): Boolean; 218 | begin 219 | Result := ContainsKey(AKey); 220 | if Result then 221 | AValue := AsString(AKey); 222 | end; 223 | 224 | end. 225 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Commons.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Commons; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$MODESWITCH TypeHelpers} 6 | {$ENDIF} 7 | 8 | interface 9 | 10 | uses 11 | {$IF DEFINED(FPC)} 12 | Classes, SysUtils, StrUtils 13 | {$ELSE} 14 | System.Classes, System.SysUtils 15 | {$ENDIF} 16 | ; 17 | 18 | type 19 | {$IF DEFINED(FPC)} 20 | TMethodType = (mtAny, mtGet, mtPut, mtPost, mtHead, mtDelete, mtPatch); 21 | {$ENDIF} 22 | 23 | {$SCOPEDENUMS ON} 24 | THTTPStatus = ( 25 | Continue = 100, 26 | SwitchingProtocols = 101, 27 | Processing = 102, 28 | OK = 200, 29 | Created = 201, 30 | Accepted = 202, 31 | NonAuthoritativeInformation = 203, 32 | NoContent = 204, 33 | ResetContent = 205, 34 | PartialContent = 206, 35 | MultiStatus = 207, 36 | AlreadyReported = 208, 37 | IMUsed = 226, 38 | MultipleChoices = 300, 39 | MovedPermanently = 301, 40 | Found = 302, 41 | SeeOther = 303, 42 | NotModified = 304, 43 | UseProxy = 305, 44 | TemporaryRedirect = 307, 45 | PermanentRedirect = 308, 46 | BadRequest = 400, 47 | Unauthorized = 401, 48 | PaymentRequired = 402, 49 | Forbidden = 403, 50 | NotFound = 404, 51 | MethodNotAllowed = 405, 52 | NotAcceptable = 406, 53 | ProxyAuthenticationRequired = 407, 54 | RequestTimeout = 408, 55 | Conflict = 409, 56 | Gone = 410, 57 | LengthRequired = 411, 58 | PreconditionFailed = 412, 59 | PayloadTooLarge = 413, 60 | RequestURITooLong = 414, 61 | UnsupportedMediaType = 415, 62 | RequestedRangeNotSatisfiable = 416, 63 | ExpectationFailed = 417, 64 | Imateapot = 418, 65 | MisdirectedRequest = 421, 66 | UnprocessableEntity = 422, 67 | Locked = 423, 68 | FailedDependency = 424, 69 | UpgradeRequired = 426, 70 | PreconditionRequired = 428, 71 | TooManyRequests = 429, 72 | RequestHeaderFieldsTooLarge = 431, 73 | ConnectionClosedWithoutResponse = 444, 74 | UnavailableForLegalReasons = 451, 75 | ClientClosedRequest = 499, 76 | InternalServerError = 500, 77 | NotImplemented = 501, 78 | BadGateway = 502, 79 | ServiceUnavailable = 503, 80 | GatewayTimeout = 504, 81 | HTTPVersionNotSupported = 505, 82 | VariantAlsoNegotiates = 506, 83 | InsufficientStorage = 507, 84 | LoopDetected = 508, 85 | NotExtended = 510, 86 | NetworkAuthenticationRequired = 511, 87 | NetworkConnectTimeoutError = 599); 88 | 89 | TMimeTypes = ( 90 | MultiPartFormData, 91 | ApplicationXWWWFormURLEncoded, 92 | ApplicationJSON, 93 | ApplicationOctetStream, 94 | ApplicationXML, 95 | ApplicationJavaScript, 96 | ApplicationPDF, 97 | ApplicationTypeScript, 98 | ApplicationZIP, 99 | TextPlain, 100 | TextCSS, 101 | TextCSV, 102 | TextHTML, 103 | ImageJPEG, 104 | ImagePNG, 105 | ImageGIF, 106 | Download); 107 | 108 | TMessageType = (Default, Error, Warning, Information); 109 | TLhsBracketsType = (Equal, NotEqual, LessThan, LessThanOrEqual, GreaterThan, GreaterThanOrEqual, Range, Like); 110 | {$SCOPEDENUMS OFF} 111 | 112 | TLhsBrackets = set of TLhsBracketsType; 113 | 114 | THTTPStatusHelper = {$IF DEFINED(FPC)} type {$ELSE} record {$ENDIF} helper for THTTPStatus 115 | function ToInteger: Integer; 116 | end; 117 | 118 | TMimeTypesHelper = {$IF DEFINED(FPC)} type {$ELSE} record {$ENDIF} helper for TMimeTypes 119 | function ToString: string; 120 | end; 121 | 122 | TLhsBracketsTypeHelper = {$IF DEFINED(FPC)} type {$ELSE} record {$ENDIF} helper for TLhsBracketsType 123 | function ToString: string; 124 | end; 125 | 126 | {$IF DEFINED(FPC)} 127 | function StringCommandToMethodType(const ACommand: string): TMethodType; 128 | {$ENDIF} 129 | 130 | implementation 131 | 132 | {$IF DEFINED(FPC)} 133 | function StringCommandToMethodType(const ACommand: string): TMethodType; 134 | begin 135 | case AnsiIndexText(ACommand, ['ANY', 'DELETE', 'GET', 'HEAD', 'PATCH', 'POST', 'PUT']) of 136 | 0: Result := TMethodType.mtAny; 137 | 1: Result := TMethodType.mtDelete; 138 | 2: Result := TMethodType.mtGet; 139 | 3: Result := TMethodType.mtHead; 140 | 4: Result := TMethodType.mtPatch; 141 | 5: Result := TMethodType.mtPost; 142 | 6: Result := TMethodType.mtPut; 143 | end; 144 | end; 145 | {$ENDIF} 146 | 147 | { TLhsBracketsTypeHelper } 148 | 149 | function TLhsBracketsTypeHelper.ToString: string; 150 | begin 151 | case Self of 152 | TLhsBracketsType.Equal: 153 | Result := '[eq]'; 154 | TLhsBracketsType.NotEqual: 155 | Result := '[ne]'; 156 | TLhsBracketsType.LessThan: 157 | Result := '[lt]'; 158 | TLhsBracketsType.LessThanOrEqual: 159 | Result := '[lte]'; 160 | TLhsBracketsType.GreaterThan: 161 | Result := '[gt]'; 162 | TLhsBracketsType.GreaterThanOrEqual: 163 | Result := '[gte]'; 164 | TLhsBracketsType.Range: 165 | Result := '[range]'; 166 | TLhsBracketsType.Like: 167 | Result := '[like]'; 168 | end; 169 | end; 170 | 171 | { THTTPStatusHelper } 172 | 173 | function THTTPStatusHelper.ToInteger: Integer; 174 | begin 175 | Result := Ord(Self); 176 | end; 177 | 178 | { TMimeTypesHelper } 179 | 180 | function TMimeTypesHelper.ToString: string; 181 | begin 182 | case Self of 183 | TMimeTypes.MultiPartFormData: 184 | Result := 'multipart/form-data'; 185 | TMimeTypes.ApplicationXWWWFormURLEncoded: 186 | Result := 'application/x-www-form-urlencoded'; 187 | TMimeTypes.ApplicationJSON: 188 | Result := 'application/json'; 189 | TMimeTypes.ApplicationOctetStream: 190 | Result := 'application/octet-stream'; 191 | TMimeTypes.ApplicationXML: 192 | Result := 'application/xml'; 193 | TMimeTypes.ApplicationJavaScript: 194 | Result := 'application/javascript'; 195 | TMimeTypes.ApplicationPDF: 196 | Result := 'application/pdf'; 197 | TMimeTypes.ApplicationTypeScript: 198 | Result := 'application/typescript'; 199 | TMimeTypes.ApplicationZIP: 200 | Result := 'application/zip'; 201 | TMimeTypes.TextPlain: 202 | Result := 'text/plain'; 203 | TMimeTypes.TextCSS: 204 | Result := 'text/css'; 205 | TMimeTypes.TextCSV: 206 | Result := 'text/csv'; 207 | TMimeTypes.TextHTML: 208 | Result := 'text/html'; 209 | TMimeTypes.ImageJPEG: 210 | Result := 'image/jpeg'; 211 | TMimeTypes.ImagePNG: 212 | Result := 'image/png'; 213 | TMimeTypes.ImageGIF: 214 | Result := 'image/gif'; 215 | TMimeTypes.Download: 216 | Result := 'application/x-download'; 217 | end; 218 | end; 219 | 220 | end. 221 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Response.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Response; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Classes, fpHTTP, HTTPDefs, 12 | {$ELSE} 13 | System.SysUtils, System.Classes, Web.HTTPApp, 14 | {$IF CompilerVersion > 32.0} 15 | Web.ReqMulti, 16 | {$ENDIF} 17 | {$ENDIF} 18 | Horse.Commons, Horse.Core.Files; 19 | 20 | type 21 | THorseResponse = class 22 | private 23 | FWebResponse: {$IF DEFINED(FPC)}TResponse{$ELSE}TWebResponse{$ENDIF}; 24 | FContent: TObject; 25 | public 26 | function Send(const AContent: string): THorseResponse; overload; 27 | function Send(AContent: T): THorseResponse; overload; 28 | function RedirectTo(const ALocation: string): THorseResponse; overload; 29 | function RedirectTo(const ALocation: string; const AStatus: THTTPStatus): THorseResponse; overload; 30 | function Status(const AStatus: Integer): THorseResponse; overload; 31 | function Status(const AStatus: THTTPStatus): THorseResponse; overload; 32 | function SendFile(const AFileStream: TStream; const AFileName: string; const AContentType: string): THorseResponse; overload; 33 | function SendFile(const AFileName: string; const AContentType: string = ''): THorseResponse; overload; 34 | function Download(const AFileName: string): THorseResponse; overload; 35 | function Render(const AFileName: string): THorseResponse; overload; 36 | function Status: Integer; overload; 37 | function AddHeader(const AName, AValue: string): THorseResponse; 38 | function Content: TObject; overload; 39 | function Content(const AContent: TObject): THorseResponse; overload; 40 | function ContentType(const AContentType: string): THorseResponse; 41 | function RawWebResponse: {$IF DEFINED(FPC)}TResponse{$ELSE}TWebResponse{$ENDIF}; 42 | constructor Create(const AWebResponse: {$IF DEFINED(FPC)}TResponse{$ELSE}TWebResponse{$ENDIF}); 43 | destructor Destroy; override; 44 | end; 45 | 46 | implementation 47 | 48 | function THorseResponse.AddHeader(const AName, AValue: string): THorseResponse; 49 | begin 50 | FWebResponse.SetCustomHeader(AName, AValue); 51 | Result := Self; 52 | end; 53 | 54 | function THorseResponse.Content(const AContent: TObject): THorseResponse; 55 | begin 56 | Result := Self; 57 | FContent := AContent; 58 | end; 59 | 60 | function THorseResponse.Content: TObject; 61 | begin 62 | Result := FContent; 63 | end; 64 | 65 | function THorseResponse.ContentType(const AContentType: string): THorseResponse; 66 | begin 67 | FWebResponse.ContentType := AContentType; 68 | Result := Self; 69 | end; 70 | 71 | constructor THorseResponse.Create(const AWebResponse: {$IF DEFINED(FPC)}TResponse{$ELSE}TWebResponse{$ENDIF}); 72 | begin 73 | FWebResponse := AWebResponse; 74 | {$IF DEFINED(FPC)}FWebResponse.Code{$ELSE}FWebResponse.StatusCode{$ENDIF} := THTTPStatus.Ok.ToInteger; 75 | 76 | {$IF DEFINED(FPC)} 77 | FWebResponse.FreeContentStream := True; 78 | {$ENDIF} 79 | end; 80 | 81 | destructor THorseResponse.Destroy; 82 | begin 83 | if Assigned(FContent) then 84 | FContent.Free; 85 | inherited; 86 | end; 87 | 88 | function THorseResponse.RawWebResponse: {$IF DEFINED(FPC)}TResponse{$ELSE}TWebResponse{$ENDIF}; 89 | begin 90 | Result := FWebResponse; 91 | end; 92 | 93 | function THorseResponse.Send(const AContent: string): THorseResponse; 94 | begin 95 | FWebResponse.Content := AContent; 96 | Result := Self; 97 | end; 98 | 99 | function THorseResponse.Send(AContent: T): THorseResponse; 100 | begin 101 | FContent := AContent; 102 | Result := Self; 103 | end; 104 | 105 | function THorseResponse.SendFile(const AFileStream: TStream; const AFileName, 106 | AContentType: string): THorseResponse; 107 | var 108 | LFileName: string; 109 | begin 110 | Result := Self; 111 | LFileName := ExtractFileName(AFileName); 112 | FWebResponse.FreeContentStream := False; 113 | FWebResponse.ContentLength := AFileStream.Size; 114 | FWebResponse.ContentStream := AFileStream; 115 | FWebResponse.SetCustomHeader('Content-Disposition', Format('inline; filename="%s"', [LFileName])); 116 | if (AContentType <> EmptyStr) then 117 | FWebResponse.ContentType := AContentType 118 | else 119 | FWebResponse.ContentType := 'application/octet-stream'; 120 | {$IF DEFINED(FPC)} 121 | FWebResponse.SendContent; 122 | {$ELSE} 123 | FWebResponse.SendResponse; 124 | {$ENDIF} 125 | end; 126 | 127 | function THorseResponse.RedirectTo(const ALocation: string): THorseResponse; 128 | begin 129 | FWebResponse.SetCustomHeader('Location', ALocation); 130 | Result := Status(THTTPStatus.SeeOther); 131 | end; 132 | 133 | function THorseResponse.RedirectTo(const ALocation: string; const AStatus: THTTPStatus): THorseResponse; 134 | begin 135 | FWebResponse.SetCustomHeader('Location', ALocation); 136 | Result := Status(AStatus); 137 | end; 138 | 139 | function THorseResponse.Status(const AStatus: THTTPStatus): THorseResponse; 140 | begin 141 | {$IF DEFINED(FPC)}FWebResponse.Code{$ELSE}FWebResponse.StatusCode{$ENDIF} := AStatus.ToInteger; 142 | Result := Self; 143 | end; 144 | 145 | function THorseResponse.SendFile(const AFileName: string; const AContentType: string): THorseResponse; 146 | var 147 | LFile: THorseCoreFile; 148 | begin 149 | Result := Self; 150 | LFile := THorseCoreFile.Create(AFileName); 151 | try 152 | FWebResponse.ContentLength := LFile.Size; 153 | FWebResponse.ContentStream := LFile.ContentStream; 154 | LFile.FreeContentStream := False; 155 | if AContentType = EmptyStr then 156 | FWebResponse.ContentType := LFile.ContentType 157 | else 158 | FWebResponse.ContentType := AContentType; 159 | {$IF DEFINED(FPC)} 160 | FWebResponse.SendContent; 161 | {$ELSE} 162 | FWebResponse.SendResponse; 163 | {$ENDIF} 164 | finally 165 | LFile.Free; 166 | end; 167 | end; 168 | 169 | function THorseResponse.Download(const AFileName: string): THorseResponse; 170 | begin 171 | Result := Self; 172 | FWebResponse.SetCustomHeader('Content-Disposition', Format('attachment; filename="%s"',[ExtractFileName(AFileName)])); 173 | 174 | SendFile(AFileName, Horse.Commons.TMimeTypes.Download.ToString); 175 | end; 176 | 177 | function THorseResponse.Render(const AFileName: string): THorseResponse; 178 | begin 179 | Result := Self; 180 | 181 | SendFile(AFileName, Horse.Commons.TMimeTypes.TextHTML.ToString); 182 | end; 183 | 184 | function THorseResponse.Status: Integer; 185 | begin 186 | Result := {$IF DEFINED(FPC)}FWebResponse.Code{$ELSE}FWebResponse.StatusCode{$ENDIF}; 187 | end; 188 | 189 | function THorseResponse.Status(const AStatus: Integer): THorseResponse; 190 | begin 191 | {$IF DEFINED(FPC)}FWebResponse.Code{$ELSE}FWebResponse.StatusCode{$ENDIF} := AStatus; 192 | Result := Self; 193 | end; 194 | 195 | end. 196 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Request.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Request; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Classes, fpHTTP, HTTPDefs, 12 | {$ELSE} 13 | System.SysUtils, System.Classes, Web.HTTPApp, 14 | {$IF CompilerVersion > 32.0} 15 | Web.ReqMulti, 16 | {$ENDIF} 17 | {$ENDIF} 18 | Horse.Core.Param, Horse.Core.Param.Header, Horse.Commons, Horse.Session; 19 | 20 | type 21 | THorseRequest = class 22 | private 23 | FWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}; 24 | FHeaders: THorseCoreParam; 25 | FQuery: THorseCoreParam; 26 | FParams: THorseCoreParam; 27 | FContentFields: THorseCoreParam; 28 | FCookie: THorseCoreParam; 29 | FBody: TObject; 30 | FSession: TObject; 31 | FSessions: THorseSessions; 32 | procedure InitializeQuery; 33 | procedure InitializeParams; 34 | procedure InitializeContentFields; 35 | procedure InitializeCookie; 36 | function IsMultipartForm: Boolean; 37 | function IsFormURLEncoded: Boolean; 38 | function CanLoadContentFields: Boolean; 39 | public 40 | function Body: string; overload; 41 | function Body: T; overload; 42 | function Body(const ABody: TObject): THorseRequest; overload; 43 | function Session: T; overload; 44 | function Session(const ASession: TObject): THorseRequest; overload; 45 | function Headers: THorseCoreParam; 46 | function Query: THorseCoreParam; 47 | function Params: THorseCoreParam; 48 | function Cookie: THorseCoreParam; 49 | function ContentFields: THorseCoreParam; 50 | function MethodType: TMethodType; 51 | function RawWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}; 52 | property Sessions: THorseSessions read FSessions; 53 | constructor Create(const AWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}); 54 | destructor Destroy; override; 55 | end; 56 | 57 | implementation 58 | 59 | function THorseRequest.Body: string; 60 | begin 61 | Result := FWebRequest.Content; 62 | end; 63 | 64 | function THorseRequest.Body(const ABody: TObject): THorseRequest; 65 | begin 66 | Result := Self; 67 | FBody := ABody; 68 | end; 69 | 70 | function THorseRequest.Body: T; 71 | begin 72 | Result := T(FBody); 73 | end; 74 | 75 | function THorseRequest.CanLoadContentFields: Boolean; 76 | begin 77 | Result := IsMultipartForm or IsFormURLEncoded; 78 | end; 79 | 80 | function THorseRequest.ContentFields: THorseCoreParam; 81 | begin 82 | if not Assigned(FContentFields) then 83 | InitializeContentFields; 84 | Result := FContentFields; 85 | end; 86 | 87 | function THorseRequest.Cookie: THorseCoreParam; 88 | begin 89 | if not Assigned(FCookie) then 90 | InitializeCookie; 91 | Result := FCookie; 92 | end; 93 | 94 | constructor THorseRequest.Create(const AWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}); 95 | begin 96 | FWebRequest := AWebRequest; 97 | FSessions := THorseSessions.Create; 98 | end; 99 | 100 | destructor THorseRequest.Destroy; 101 | begin 102 | if Assigned(FHeaders) then 103 | FreeAndNil(FHeaders); 104 | if Assigned(FQuery) then 105 | FreeAndNil(FQuery); 106 | if Assigned(FParams) then 107 | FreeAndNil(FParams); 108 | if Assigned(FContentFields) then 109 | FreeAndNil(FContentFields); 110 | if Assigned(FCookie) then 111 | FreeAndNil(FCookie); 112 | if Assigned(FBody) then 113 | FBody.Free; 114 | if Assigned(FSessions) then 115 | FSessions.Free; 116 | inherited; 117 | end; 118 | 119 | function THorseRequest.Headers: THorseCoreParam; 120 | var 121 | LParam: THorseList; 122 | begin 123 | if not Assigned(FHeaders) then 124 | begin 125 | LParam := THorseCoreParamHeader.GetHeaders(FWebRequest); 126 | FHeaders := THorseCoreParam.Create(LParam).Required(False); 127 | end; 128 | result := FHeaders; 129 | end; 130 | 131 | procedure THorseRequest.InitializeContentFields; 132 | var 133 | I: Integer; 134 | begin 135 | FContentFields := THorseCoreParam.Create(THorseList.Create).Required(False); 136 | if (not CanLoadContentFields) then 137 | Exit; 138 | 139 | for I := 0 to Pred(FWebRequest.Files.Count) do 140 | FContentFields.AddStream(FWebRequest.Files[I].FieldName, FWebRequest.Files[I].Stream); 141 | 142 | for I := 0 to Pred(FWebRequest.ContentFields.Count) do 143 | FContentFields.Dictionary.AddOrSetValue(FWebRequest.ContentFields.Names[I], FWebRequest.ContentFields.ValueFromIndex[I]); 144 | end; 145 | 146 | procedure THorseRequest.InitializeCookie; 147 | const 148 | KEY = 0; 149 | VALUE = 1; 150 | var 151 | LParam: TArray; 152 | LItem: string; 153 | begin 154 | FCookie := THorseCoreParam.Create(THorseList.Create).Required(False); 155 | for LItem in FWebRequest.CookieFields do 156 | begin 157 | LParam := LItem.Split(['=']); 158 | FCookie.Dictionary.AddOrSetValue(LParam[KEY], LParam[VALUE]); 159 | end; 160 | end; 161 | 162 | procedure THorseRequest.InitializeParams; 163 | begin 164 | FParams := THorseCoreParam.Create(THorseList.Create).Required(True); 165 | end; 166 | 167 | procedure THorseRequest.InitializeQuery; 168 | var 169 | LItem, LKey, LValue: string; 170 | LEqualFirstPos: Integer; 171 | begin 172 | FQuery := THorseCoreParam.Create(THorseList.Create).Required(False); 173 | for LItem in FWebRequest.QueryFields do 174 | begin 175 | LEqualFirstPos := Pos('=', Litem); 176 | LKey := Copy(Litem, 1, LEqualFirstPos - 1); 177 | LValue := Copy(Litem, LEqualFirstPos + 1, Length(LItem)); 178 | FQuery.Dictionary.AddOrSetValue(LKey, LValue); 179 | end; 180 | end; 181 | 182 | function THorseRequest.IsFormURLEncoded: Boolean; 183 | begin 184 | Result := StrLIComp(PChar(FWebRequest.ContentType), PChar(TMimeTypes.ApplicationXWWWFormURLEncoded.ToString), 185 | Length(TMimeTypes.ApplicationXWWWFormURLEncoded.ToString)) = 0; 186 | end; 187 | 188 | function THorseRequest.IsMultipartForm: Boolean; 189 | begin 190 | Result := StrLIComp(PChar(FWebRequest.ContentType), PChar(TMimeTypes.MultiPartFormData.ToString), 191 | Length(TMimeTypes.MultiPartFormData.ToString)) = 0; 192 | end; 193 | 194 | function THorseRequest.MethodType: TMethodType; 195 | begin 196 | Result := {$IF DEFINED(FPC)}StringCommandToMethodType(FWebRequest.Method);{$ELSE}FWebRequest.MethodType;{$ENDIF} 197 | end; 198 | 199 | function THorseRequest.Params: THorseCoreParam; 200 | begin 201 | if not Assigned(FParams) then 202 | InitializeParams; 203 | Result := FParams; 204 | end; 205 | 206 | function THorseRequest.Query: THorseCoreParam; 207 | begin 208 | if not Assigned(FQuery) then 209 | InitializeQuery; 210 | Result := FQuery; 211 | end; 212 | 213 | function THorseRequest.RawWebRequest: {$IF DEFINED(FPC)}TRequest{$ELSE}TWebRequest{$ENDIF}; 214 | begin 215 | Result := FWebRequest; 216 | end; 217 | 218 | function THorseRequest.Session(const ASession: TObject): THorseRequest; 219 | begin 220 | Result := Self; 221 | FSession := ASession; 222 | end; 223 | 224 | function THorseRequest.Session: T; 225 | begin 226 | Result := T(FSession); 227 | end; 228 | 229 | end. 230 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.FPC.Daemon.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.FPC.Daemon; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | {$IF DEFINED(HORSE_DAEMON)} 10 | uses SysUtils, Classes, httpdefs, fpHTTP, fphttpserver, Horse.Request, Horse.Response, Horse.Core, Horse.Provider.Abstract, Horse.Constants, 11 | Horse.Proc, Horse.Commons, Horse.Exception; 12 | 13 | type 14 | THTTPServerThread = class(TThread) 15 | private 16 | FStartServer: Boolean; 17 | FHost: string; 18 | FPort: Integer; 19 | FListenQueue: Word; 20 | FServer: TFPHTTPServer; 21 | FHorse: THorseCore; 22 | public 23 | constructor Create(const ACreateSuspended: Boolean; const AStackSize: SizeUInt = DefaultStackSize); 24 | destructor Destroy; override; 25 | procedure StartServer; 26 | procedure StopServer; 27 | property Port: Integer read FPort write FPort; 28 | property Host: String read FHost write FHost; 29 | property ListenQueue: Word read FListenQueue write FListenQueue; 30 | procedure Execute; override; 31 | procedure OnRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse); 32 | end; 33 | 34 | THorseProvider = class(THorseProviderAbstract) 35 | private 36 | class var FPort: Integer; 37 | class var FHost: string; 38 | class var FRunning: Boolean; 39 | class var FListenQueue: Integer; 40 | class var FHTTPServerThread: THTTPServerThread; 41 | class function GetDefaultHTTPServerThread: THTTPServerThread; 42 | class function HTTPServerThreadIsNil: Boolean; 43 | class procedure SetListenQueue(const AValue: Integer); static; 44 | class procedure SetPort(const AValue: Integer); static; 45 | class procedure SetHost(const AValue: string); static; 46 | class function GetListenQueue: Integer; static; 47 | class function GetPort: Integer; static; 48 | class function GetDefaultPort: Integer; static; 49 | class function GetDefaultHost: string; static; 50 | class function GetHost: string; static; 51 | class procedure InternalListen; virtual; 52 | class procedure InternalStopListen; virtual; 53 | public 54 | class property Host: string read GetHost write SetHost; 55 | class property Port: Integer read GetPort write SetPort; 56 | class property ListenQueue: Integer read GetListenQueue write SetListenQueue; 57 | class procedure StopListen; override; 58 | class procedure Listen; overload; override; 59 | class procedure Listen(const APort: Integer; const AHost: string = '0.0.0.0'; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 60 | class procedure Listen(const APort: Integer; const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 61 | class procedure Listen(const AHost: string; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 62 | class procedure Listen(const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 63 | class destructor UnInitialize; 64 | class function IsRunning: Boolean; 65 | end; 66 | {$ENDIF} 67 | 68 | implementation 69 | 70 | {$IF DEFINED(HORSE_DAEMON) AND DEFINED(FPC)} 71 | uses Horse.WebModule, Horse.Exception.Interrupted; 72 | 73 | class function THorseProvider.GetDefaultHTTPServerThread: THTTPServerThread; 74 | begin 75 | if HTTPServerThreadIsNil then 76 | FHTTPServerThread := THTTPServerThread.Create(True); 77 | Result := FHTTPServerThread; 78 | end; 79 | 80 | class function THorseProvider.IsRunning: Boolean; 81 | begin 82 | Result := FRunning; 83 | end; 84 | 85 | class function THorseProvider.HTTPServerThreadIsNil: Boolean; 86 | begin 87 | Result := FHTTPServerThread = nil; 88 | end; 89 | 90 | class procedure THorseProvider.StopListen; 91 | begin 92 | InternalStopListen; 93 | end; 94 | 95 | class function THorseProvider.GetDefaultHost: string; 96 | begin 97 | Result := DEFAULT_HOST; 98 | end; 99 | 100 | class function THorseProvider.GetDefaultPort: Integer; 101 | begin 102 | Result := DEFAULT_PORT; 103 | end; 104 | 105 | class function THorseProvider.GetHost: string; 106 | begin 107 | Result := FHost; 108 | end; 109 | 110 | class function THorseProvider.GetListenQueue: Integer; 111 | begin 112 | Result := FListenQueue; 113 | end; 114 | 115 | class function THorseProvider.GetPort: Integer; 116 | begin 117 | Result := FPort; 118 | end; 119 | 120 | class procedure THorseProvider.InternalListen; 121 | var 122 | LHTTPServerThread: THTTPServerThread; 123 | begin 124 | inherited; 125 | if FPort <= 0 then 126 | FPort := GetDefaultPort; 127 | if FHost.IsEmpty then 128 | FHost := GetDefaultHost; 129 | if FListenQueue = 0 then 130 | FListenQueue := 15; 131 | LHTTPServerThread := GetDefaultHTTPServerThread; 132 | LHTTPServerThread.Port := FPort; 133 | LHTTPServerThread.Host := FHost; 134 | LHTTPServerThread.ListenQueue := FListenQueue; 135 | LHTTPServerThread.StartServer; 136 | FRunning := True; 137 | DoOnListen; 138 | end; 139 | 140 | class procedure THorseProvider.Listen; 141 | begin 142 | InternalListen; 143 | end; 144 | 145 | class procedure THorseProvider.Listen(const APort: Integer; const AHost: string; const ACallbackListen, ACallbackStopListen: TProc); 146 | begin 147 | SetPort(APort); 148 | SetHost(AHost); 149 | SetOnListen(ACallbackListen); 150 | SetOnStopListen(ACallbackStopListen); 151 | InternalListen; 152 | end; 153 | 154 | class procedure THorseProvider.Listen(const AHost: string; const ACallbackListen, ACallbackStopListen: TProc); 155 | begin 156 | Listen(FPort, AHost, ACallbackListen, ACallbackStopListen); 157 | end; 158 | 159 | class procedure THorseProvider.Listen(const ACallbackListen, ACallbackStopListen: TProc); 160 | begin 161 | Listen(FPort, FHost, ACallbackListen, ACallbackStopListen); 162 | end; 163 | 164 | class procedure THorseProvider.Listen(const APort: Integer; const ACallbackListen, ACallbackStopListen: TProc); 165 | begin 166 | Listen(APort, FHost, ACallbackListen, ACallbackStopListen); 167 | end; 168 | 169 | class procedure THorseProvider.SetHost(const AValue: string); 170 | begin 171 | FHost := AValue; 172 | end; 173 | 174 | class procedure THorseProvider.SetListenQueue(const AValue: Integer); 175 | begin 176 | FListenQueue := AValue; 177 | end; 178 | 179 | class procedure THorseProvider.SetPort(const AValue: Integer); 180 | begin 181 | FPort := AValue; 182 | end; 183 | 184 | class destructor THorseProvider.UnInitialize; 185 | begin 186 | FreeAndNil(FHTTPServerThread); 187 | end; 188 | 189 | class procedure THorseProvider.InternalStopListen; 190 | begin 191 | if not HTTPServerThreadIsNil then 192 | begin 193 | GetDefaultHTTPServerThread.StopServer; 194 | DoOnStopListen; 195 | FRunning := False; 196 | end 197 | else 198 | raise Exception.Create('Horse not listen'); 199 | end; 200 | 201 | procedure THTTPServerThread.OnRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest; var AResponse: TFPHTTPConnectionResponse); 202 | var 203 | LRequest: THorseRequest; 204 | LResponse: THorseResponse; 205 | begin 206 | LRequest := THorseRequest.Create(ARequest); 207 | LResponse := THorseResponse.Create(AResponse); 208 | try 209 | try 210 | if not FHorse.Routes.Execute(LRequest, LResponse) then 211 | begin 212 | AResponse.Content := 'Not Found'; 213 | AResponse.Code := THTTPStatus.NotFound.ToInteger; 214 | end; 215 | except 216 | on E: Exception do 217 | if not E.InheritsFrom(EHorseCallbackInterrupted) then 218 | raise; 219 | end; 220 | finally 221 | if LRequest.Body = LResponse.Content then 222 | LResponse.Content(nil); 223 | LRequest.Free; 224 | LResponse.Free; 225 | end; 226 | end; 227 | 228 | constructor THTTPServerThread.Create(const ACreateSuspended: Boolean; const AStackSize: SizeUInt = DefaultStackSize); 229 | begin 230 | inherited Create(ACreateSuspended, AStackSize); 231 | FreeOnTerminate := True; 232 | FStartServer := False; 233 | FServer := TFPHttpServer.Create(Nil); 234 | FServer.OnRequest := OnRequest; 235 | FHorse := THorseCore.GetInstance; 236 | end; 237 | 238 | destructor THTTPServerThread.Destroy; 239 | begin 240 | if Assigned(FServer) then 241 | FServer.Active := False; 242 | FreeAndNil(FServer); 243 | inherited Destroy; 244 | end; 245 | 246 | procedure THTTPServerThread.StartServer; 247 | begin 248 | Start; 249 | FStartServer := True; 250 | end; 251 | 252 | procedure THTTPServerThread.StopServer; 253 | begin 254 | FStartServer := False; 255 | FServer.Active := FStartServer; 256 | end; 257 | 258 | procedure THTTPServerThread.Execute; 259 | begin 260 | while not Terminated do 261 | begin 262 | if FStartServer then 263 | begin 264 | FServer.HostName := FHost; 265 | FServer.Port := FPort; 266 | FServer.Threaded:= True; 267 | FServer.QueueSize := FListenQueue; 268 | FServer.Active := True; 269 | end; 270 | end; 271 | end; 272 | {$ENDIF} 273 | 274 | end. 275 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Maintained YES](https://img.shields.io/badge/Maintained%3F-yes-green.svg?style=flat-square&color=important) 2 | ![Memory Leak Verified YES](https://img.shields.io/badge/Memory%20Leak%20Verified%3F-yes-green.svg?style=flat-square&color=important) 3 | ![Release](https://img.shields.io/github/v/release/antoniojmsjr/FastReportExport?label=Latest%20release&style=flat-square&color=important) 4 | ![Stars](https://img.shields.io/github/stars/antoniojmsjr/FastReportExport.svg?style=flat-square) 5 | ![Forks](https://img.shields.io/github/forks/antoniojmsjr/FastReportExport.svg?style=flat-square) 6 | ![Issues](https://img.shields.io/github/issues/antoniojmsjr/FastReportExport.svg?style=flat-square&color=blue)
7 | ![Compatibility](https://img.shields.io/badge/Compatibility-VCL,%20Firemonkey,%20DataSnap,%20Horse,%20RDW,%20RADServer-3db36a?style=flat-square) 8 | ![Delphi Supported Versions](https://img.shields.io/badge/Delphi%20Supported%20Versions-XE7%20and%20newer-3db36a?style=flat-square) 9 | ![Fastreport Supported Versions](https://img.shields.io/badge/Fast%20Report%20Supported%20Versions-5.1.5%20and%20newer-3db36a?style=flat-square) 10 | 11 | # FastReportExport 12 | 13 | **FastReportExport** é uma biblioteca para exportação de relatórios com [Fast Report](https://www.fast-report.com) para ambientes **multithreading** e não **GUI(Graphical User Interface)**. 14 | 15 | Implementado na linguagem Delphi, utiliza o conceito de [fluent interface](https://en.wikipedia.org/wiki/Fluent_interface) para guiar no uso da biblioteca, desenvolvido para exportar relatórios nos formatos PDF, HTML, PNG, entre outros, conforme a necessidade. 16 | 17 | **Ambientes** 18 | 19 | * Windows Forms 20 | * Windows Console 21 | * Windows Service 22 | * IIS ISAPI[(Horse)](https://github.com/HashLoad/horse) 23 | * IIS CGI[(Horse)](https://github.com/HashLoad/horse) 24 | 25 | ## ⭕ Pré-requisito 26 | 27 | Para utilizar o **FastReportExport** é necessário a instalação do componente [Fast Report](https://www.fast-report.com). 28 | 29 | ## ⚙️ Instalação Automatizada 30 | 31 | Utilizando o [**Boss**](https://github.com/HashLoad/boss/releases/latest) (Dependency manager for Delphi) é possível instalar a biblioteca de forma automática. 32 | 33 | ``` 34 | boss install github.com/antoniojmsjr/FastReportExport 35 | ``` 36 | 37 | ## ⚙️ Instalação Manual 38 | 39 | Se você optar por instalar manualmente, basta adicionar as seguintes pastas ao seu projeto, em *Project > Options > Delphi Compiler > Target > All Configurations > Search path* 40 | 41 | ``` 42 | ..\FastReportExport\Source 43 | ``` 44 | 45 | ## 🧬 Provedores de Exportação 46 | 47 | **Providers** é uma interface utilizada pela biblioteca para exportação dos relatórios que disponibiliza a classe **TfrxCustomExportFilter** para configuração, e pode ser extendida para implementação de outros formatos de arquivo. 48 | 49 | | Arquivo | Provedor | TfrxCustomExportFilter | 50 | |---|---|---| 51 | | PDF | IFRExportPDF | TfrxPDFExport | 52 | | HTML | IFRExportHTML | TfrxHTMLExport | 53 | | PNG | IFRExportPNG | TfrxPNGExport | 54 | | BMP | IFRExportBMP | TfrxBMPExport | 55 | | JPEG | IFRExportJPEG | TfrxJPEGExport | 56 | | CSV | IFRExportCSV | TfrxCSVExport | 57 | | RTF | IFRExportRTF | TfrxRTFExport | 58 | | XLS | IFRExportXLS | TfrxXLSExport | 59 | | XLSX | IFRExportXLSX | TfrxXLSXExport | 60 | | DOCX | IFRExportDOCX | TfrxDOCXExport | 61 | 62 | **Exemplo** 63 | 64 | ```delphi 65 | var 66 | lFRExportPDF: IFRExportPDF; 67 | lFRExportHTML: IFRExportHTML; 68 | lFRExportPNG: IFRExportPNG; 69 | begin 70 | 71 | //PROVIDER PDF 72 | lFRExportPDF := TFRExportProviderPDF.New; 73 | lFRExportPDF.frxPDF.Subject := 'Samples Fast Report Export'; 74 | lFRExportPDF.frxPDF.Author := 'Antônio José Medeiros Schneider'; 75 | 76 | //PROVIDER HTML 77 | lFRExportHTML := TFRExportProviderHTML.New; 78 | 79 | //PROVIDER PNG 80 | lFRExportPNG := TFRExportProviderPNG.New; 81 | lFRExportPNG.frxPNG.JPEGQuality := 100; 82 | 83 | end; 84 | ``` 85 | 86 | ## 🧬 DataSet de Exportação 87 | 88 | **DataSets** é uma interface utilizada pela biblioteca para comunicação com o banco de dados através dos componentes: 89 | 90 | | Classe | Componente | 91 | |---|---| 92 | | TDataSet | Nativo | 93 | | TfrxDBDataset | Fast Report | 94 | 95 | ## ⚡️ Uso da biblioteca 96 | 97 | Para exemplificar o uso do biblioteca foi utilizado os dados da **[API de localidades do IBGE](https://servicodados.ibge.gov.br/api/docs/localidades)** para geração e exportação do relatório. 98 | 99 | Arquivo de exemplo da exportação: [LocalidadesIBGE.pdf](https://github.com/antoniojmsjr/FastReportExport/files/9128761/LocalidadesIBGE.pdf) 100 | 101 | Os exemplos estão disponíveis na pasta do projeto: 102 | 103 | ``` 104 | ..\FastReportExport\Samples 105 | ``` 106 | 107 | **Banco de dados de exemplo** 108 | 109 | * Firebird: 2.5.7 [Donwload](http://sourceforge.net/projects/firebird/files/firebird-win32/2.5.7-Release/Firebird-2.5.7.27050_0_Win32.exe/download) 110 | * Arquivo BD: 111 | ``` 112 | ..\FastReportExport\Samples\DB 113 | ``` 114 | 115 | **Relatório de exemplo** 116 | 117 | ``` 118 | ..\FastReportExport\Samples\Report 119 | ``` 120 | **Exemplo** 121 | 122 | ```delphi 123 | uses FRExport, FRExport.Types, FRExport.Interfaces.Providers; 124 | ``` 125 | ```delphi 126 | var 127 | lFRExportPDF: IFRExportPDF; 128 | lFRExportHTML: IFRExportHTML; 129 | lFRExportPNG: IFRExportPNG; 130 | lFileStream: TFileStream; 131 | lFileExport: string; 132 | begin 133 | 134 | //PROVIDER PDF 135 | lFRExportPDF := TFRExportProviderPDF.New; 136 | lFRExportPDF.frxPDF.Subject := 'Samples Fast Report Export'; 137 | lFRExportPDF.frxPDF.Author := 'Antônio José Medeiros Schneider'; 138 | 139 | //PROVIDER HTML 140 | lFRExportHTML := TFRExportProviderHTML.New; 141 | 142 | //PROVIDER PNG 143 | lFRExportPNG := TFRExportProviderPNG.New; 144 | lFRExportPNG.frxPNG.JPEGQuality := 100; 145 | 146 | //CLASSE DE EXPORTAÇÃO 147 | try 148 | TFRExport.New. 149 | DataSets. 150 | SetDataSet(qryEstadosBrasil, 'EstadosBrasil'). 151 | SetDataSet(frxdbMunicipioEstado). 152 | SetDataSet(frxdbMunicipioRegiao). 153 | SetDataSet(qryEstadoRegiao, 'EstadoRegiao'). 154 | SetDataSet(qryMunicipios, 'Municipios'). 155 | &End. 156 | Providers. 157 | SetProvider(lFRExportPDF). 158 | SetProvider(lFRExportHTML). 159 | SetProvider(lFRExportPNG). 160 | &End. 161 | Export. 162 | SetFileReport(TUtils.PathAppFileReport). //LOCAL DO RELATÓRIO *.fr3 163 | Report(procedure(pfrxReport: TfrxReport) //CONFIGURAÇÃO DO COMPONENTE DE RELATÓRIO DO FAST REPORT 164 | var 165 | lfrxComponent: TfrxComponent; 166 | lfrxMemoView: TfrxMemoView absolute lfrxComponent; 167 | begin 168 | pfrxReport.ReportOptions.Author := 'Antônio José Medeiros Schneider'; 169 | 170 | //PASSAGEM DE PARÂMETRO PARA O RELATÓRIO 171 | lfrxComponent := pfrxReport.FindObject('mmoProcess'); 172 | if Assigned(lfrxComponent) then 173 | begin 174 | lfrxMemoView.Memo.Clear; 175 | lfrxMemoView.Memo.Text := Format('Aplicativo de Exemplo: %s', ['VCL']); 176 | end; 177 | 178 | //VARIÁVEIS DO RELATÓRIO 179 | pfrxReport.Variables.Variables['DATA_HORA_IMPRESSAO'] := QuotedStr(DateTimeToStr(Now)); 180 | end). 181 | Execute; //EXECUTA O PROCESSO DE EXPORTAÇÃO DO RELATÓRIO 182 | except 183 | on E: Exception do 184 | begin 185 | if E is EFRExport then 186 | ShowMessage(E.ToString) 187 | else 188 | ShowMessage(E.Message); 189 | Exit; 190 | end; 191 | end; 192 | 193 | //SALVAR PDF 194 | if Assigned(lFRExportPDF.Stream) then 195 | begin 196 | lFileStream := nil; 197 | try 198 | lFileExport := Format('%s%s', [TUtils.PathApp, 'LocalidadesIBGE.pdf']); 199 | lFileStream := TFileStream.Create(lFileExport, fmCreate); 200 | lFileStream.CopyFrom(lFRExportPDF.Stream, 0); 201 | finally 202 | FreeAndNil(lFileStream); 203 | end; 204 | end; 205 | 206 | //SALVAR HTML 207 | if Assigned(lFRExportHTML.Stream) then 208 | begin 209 | lFileStream := nil; 210 | try 211 | lFileExport := Format('%s%s', [TUtils.PathApp, 'LocalidadesIBGE.html']); 212 | lFileStream := TFileStream.Create(lFileExport, fmCreate); 213 | lFileStream.CopyFrom(lFRExportHTML.Stream, 0); 214 | finally 215 | FreeAndNil(lFileStream); 216 | end; 217 | end; 218 | 219 | //SALVAR PNG 220 | if Assigned(lFRExportPNG.Stream) then 221 | begin 222 | lFileStream := nil; 223 | try 224 | lFileExport := Format('%s%s', [TUtils.PathApp, 'LocalidadesIBGE.png']); 225 | lFileStream := TFileStream.Create(lFileExport, fmCreate); 226 | lFileStream.CopyFrom(lFRExportPNG.Stream, 0); 227 | finally 228 | FreeAndNil(lFileStream); 229 | end; 230 | end; 231 | end; 232 | ``` 233 | 234 | **Exemplo compilado** 235 | 236 | * VCL 237 | * VCL Server [(Horse)](https://github.com/HashLoad/horse) 238 | * VCL Client [(Horse)](https://github.com/HashLoad/horse) 239 | 240 | Download: [Demo.zip](https://github.com/antoniojmsjr/FastReportExport/files/9559949/Demo.zip) 241 | 242 | **Teste de stress para aplicações web usando [JMeter](https://jmeter.apache.org/):** 243 | 244 | ``` 245 | ..\FastReportExport\Samples\JMeter 246 | ``` 247 | 248 | https://user-images.githubusercontent.com/20980984/173268272-dc81f411-b2e5-4030-8c56-c461527f2ebc.mp4 249 | 250 | 251 | ## ⚠️ Licença 252 | `FastReportExport` is free and open-source software licensed under the [![License](https://img.shields.io/badge/license-Apache%202-blue.svg)](https://github.com/antoniojmsjr/Horse-IPGeoLocation/blob/master/LICENSE) 253 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.RouterTree.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.RouterTree; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, Generics.Collections, fpHTTP, httpprotocol, 12 | {$ELSE} 13 | System.SysUtils, System.NetEncoding, Web.HTTPApp, System.Generics.Collections, 14 | {$ENDIF} 15 | Horse.Request, Horse.Response, Horse.Proc, Horse.Commons, Horse.Callback; 16 | 17 | type 18 | PHorseRouterTree = ^THorseRouterTree; 19 | 20 | THorseRouterTree = class 21 | strict private 22 | FPrefix: string; 23 | FIsInitialized: Boolean; 24 | function GetQueuePath(APath: string; const AUsePrefix: Boolean = True): TQueue; 25 | function ForcePath(const APath: string): THorseRouterTree; 26 | private 27 | FPart: string; 28 | FTag: string; 29 | FIsRegex: Boolean; 30 | FMiddleware: TList; 31 | FRegexedKeys: TList; 32 | FCallBack: TObjectDictionary>; 33 | FRoute: TObjectDictionary; 34 | procedure RegisterInternal(const AHTTPType: TMethodType; var APath: TQueue; const ACallback: THorseCallback); 35 | procedure RegisterMiddlewareInternal(var APath: TQueue; const AMiddleware: THorseCallback); 36 | function ExecuteInternal(const APath: TQueue; const AHTTPType: TMethodType; const ARequest: THorseRequest; const AResponse: THorseResponse; const AIsGroup: Boolean = False): Boolean; 37 | function CallNextPath(var APath: TQueue; const AHTTPType: TMethodType; const ARequest: THorseRequest; const AResponse: THorseResponse): Boolean; 38 | function HasNext(const AMethod: TMethodType; const APaths: TArray; AIndex: Integer = 0): Boolean; 39 | public 40 | function CreateRouter(const APath: string): THorseRouterTree; 41 | function GetPrefix: string; 42 | procedure Prefix(const APrefix: string); 43 | procedure RegisterRoute(const AHTTPType: TMethodType; const APath: string; const ACallback: THorseCallback); 44 | procedure RegisterMiddleware(const APath: string; const AMiddleware: THorseCallback); overload; 45 | procedure RegisterMiddleware(const AMiddleware: THorseCallback); overload; 46 | function Execute(const ARequest: THorseRequest; const AResponse: THorseResponse): Boolean; 47 | constructor Create; 48 | destructor Destroy; override; 49 | end; 50 | 51 | implementation 52 | 53 | uses Horse.Exception, Horse.Core.RouterTree.NextCaller; 54 | 55 | procedure THorseRouterTree.RegisterRoute(const AHTTPType: TMethodType; const APath: string; const ACallback: THorseCallback); 56 | var 57 | LPathChain: TQueue; 58 | begin 59 | LPathChain := GetQueuePath(APath); 60 | try 61 | RegisterInternal(AHTTPType, LPathChain, ACallback); 62 | finally 63 | LPathChain.Free; 64 | end; 65 | end; 66 | 67 | function THorseRouterTree.CallNextPath(var APath: TQueue; const AHTTPType: TMethodType; const ARequest: THorseRequest; 68 | const AResponse: THorseResponse): Boolean; 69 | var 70 | LCurrent, LKey: string; 71 | LAcceptable: THorseRouterTree; 72 | LFound, LIsGroup: Boolean; 73 | LPathOrigin: TQueue; 74 | begin 75 | LIsGroup := False; 76 | LPathOrigin := APath; 77 | LCurrent := APath.Peek; 78 | LFound := FRoute.TryGetValue(LCurrent, LAcceptable); 79 | if (not LFound) then 80 | begin 81 | LFound := FRoute.TryGetValue(EmptyStr, LAcceptable); 82 | if (LFound) then 83 | APath := LPathOrigin; 84 | LIsGroup := LFound; 85 | end; 86 | if (not LFound) and (FRegexedKeys.Count > 0) then 87 | begin 88 | for LKey in FRegexedKeys do 89 | begin 90 | FRoute.TryGetValue(LKey, LAcceptable); 91 | if LAcceptable.HasNext(AHTTPType, APath.ToArray) then 92 | begin 93 | LFound := LAcceptable.ExecuteInternal(APath, AHTTPType, ARequest, AResponse); 94 | Break; 95 | end; 96 | end; 97 | end 98 | else if LFound then 99 | LFound := LAcceptable.ExecuteInternal(APath, AHTTPType, ARequest, AResponse, LIsGroup); 100 | Result := LFound; 101 | end; 102 | 103 | constructor THorseRouterTree.Create; 104 | begin 105 | FMiddleware := TList.Create; 106 | FRoute := TObjectDictionary.Create([doOwnsValues]); 107 | FRegexedKeys := TList.Create; 108 | FCallBack := TObjectDictionary < TMethodType, TList < THorseCallback >>.Create([doOwnsValues]); 109 | FPrefix := ''; 110 | end; 111 | 112 | destructor THorseRouterTree.Destroy; 113 | begin 114 | FMiddleware.Free; 115 | FreeAndNil(FRoute); 116 | FRegexedKeys.Clear; 117 | FRegexedKeys.Free; 118 | FCallBack.Free; 119 | inherited; 120 | end; 121 | 122 | function THorseRouterTree.Execute(const ARequest: THorseRequest; const AResponse: THorseResponse): Boolean; 123 | var 124 | LQueue: TQueue; 125 | begin 126 | LQueue := GetQueuePath({$IF DEFINED(FPC)}ARequest.RawWebRequest.PathInfo{$ELSE}ARequest.RawWebRequest.RawPathInfo{$ENDIF}, False); 127 | try 128 | Result := ExecuteInternal(LQueue, {$IF DEFINED(FPC)} StringCommandToMethodType(ARequest.RawWebRequest.Method) 129 | {$ELSE} ARequest.RawWebRequest.MethodType{$ENDIF}, ARequest, AResponse); 130 | finally 131 | LQueue.Free; 132 | end; 133 | end; 134 | 135 | function THorseRouterTree.ExecuteInternal(const APath: TQueue; const AHTTPType: TMethodType; const ARequest: THorseRequest; 136 | const AResponse: THorseResponse; const AIsGroup: Boolean = False): Boolean; 137 | var 138 | LNextCaller: TNextCaller; 139 | LFound: Boolean; 140 | begin 141 | LFound := False; 142 | LNextCaller := TNextCaller.Create; 143 | try 144 | LNextCaller.SetCallback(FCallBack); 145 | LNextCaller.SetPath(APath); 146 | LNextCaller.SetHTTPType(AHTTPType); 147 | LNextCaller.SetRequest(ARequest); 148 | LNextCaller.SetResponse(AResponse); 149 | LNextCaller.SetIsGroup(AIsGroup); 150 | LNextCaller.SetMiddleware(FMiddleware); 151 | LNextCaller.SetTag(FTag); 152 | LNextCaller.SetIsRegex(FIsRegex); 153 | LNextCaller.SetOnCallNextPath(CallNextPath); 154 | LNextCaller.SetFound(LFound); 155 | LNextCaller.Init; 156 | LNextCaller.Next; 157 | finally 158 | LNextCaller.Free; 159 | Result := LFound; 160 | end; 161 | end; 162 | 163 | function THorseRouterTree.ForcePath(const APath: string): THorseRouterTree; 164 | begin 165 | if not FRoute.TryGetValue(APath, Result) then 166 | begin 167 | Result := THorseRouterTree.Create; 168 | FRoute.Add(APath, Result); 169 | end; 170 | end; 171 | 172 | function THorseRouterTree.CreateRouter(const APath: string): THorseRouterTree; 173 | begin 174 | Result := ForcePath(APath); 175 | end; 176 | 177 | procedure THorseRouterTree.Prefix(const APrefix: string); 178 | begin 179 | FPrefix := '/' + APrefix.Trim(['/']); 180 | end; 181 | 182 | function THorseRouterTree.GetPrefix: string; 183 | begin 184 | Result := FPrefix; 185 | end; 186 | 187 | function THorseRouterTree.GetQueuePath(APath: string; const AUsePrefix: Boolean = True): TQueue; 188 | var 189 | LPart: string; 190 | LSplitedPath: TArray; 191 | begin 192 | Result := TQueue.Create; 193 | if AUsePrefix then 194 | if not APath.StartsWith('/') then 195 | APath := (FPrefix + '/' + APath) 196 | else 197 | APath := (FPrefix + APath); 198 | LSplitedPath := APath.Split(['/']); 199 | for LPart in LSplitedPath do 200 | begin 201 | if (Result.Count > 0) and LPart.IsEmpty then 202 | Continue; 203 | Result.Enqueue(LPart); 204 | end; 205 | end; 206 | 207 | function THorseRouterTree.HasNext(const AMethod: TMethodType; const APaths: TArray; AIndex: Integer = 0): Boolean; 208 | var 209 | LNext, LKey: string; 210 | LNextRoute: THorseRouterTree; 211 | begin 212 | Result := False; 213 | if (Length(APaths) <= AIndex) then 214 | Exit(False); 215 | if (Length(APaths) - 1 = AIndex) and ((APaths[AIndex] = FPart) or (FIsRegex)) then 216 | Exit(FCallBack.ContainsKey(AMethod) or (AMethod = mtAny)); 217 | 218 | LNext := APaths[AIndex + 1]; 219 | Inc(AIndex); 220 | if FRoute.TryGetValue(LNext, LNextRoute) then 221 | begin 222 | Result := LNextRoute.HasNext(AMethod, APaths, AIndex); 223 | end 224 | else 225 | begin 226 | for LKey in FRegexedKeys do 227 | begin 228 | if FRoute.Items[LKey].HasNext(AMethod, APaths, AIndex) then 229 | Exit(True); 230 | end; 231 | end; 232 | end; 233 | 234 | procedure THorseRouterTree.RegisterInternal(const AHTTPType: TMethodType; var APath: TQueue; const ACallback: THorseCallback); 235 | var 236 | LNextPart: string; 237 | LCallbacks: TList; 238 | begin 239 | if not FIsInitialized then 240 | begin 241 | FPart := APath.Dequeue; 242 | FIsRegex := FPart.StartsWith(':'); 243 | FTag := FPart.Substring(1, Length(FPart) - 1); 244 | FIsInitialized := True; 245 | end 246 | else 247 | APath.Dequeue; 248 | 249 | if APath.Count = 0 then 250 | begin 251 | if not FCallBack.TryGetValue(AHTTPType, LCallbacks) then 252 | begin 253 | LCallbacks := TList.Create; 254 | FCallBack.Add(AHTTPType, LCallbacks); 255 | end; 256 | LCallbacks.Add(ACallback) 257 | end; 258 | 259 | if APath.Count > 0 then 260 | begin 261 | LNextPart := APath.Peek; 262 | ForcePath(LNextPart).RegisterInternal(AHTTPType, APath, ACallback); 263 | if ForcePath(LNextPart).FIsRegex then 264 | FRegexedKeys.Add(LNextPart); 265 | end; 266 | end; 267 | 268 | procedure THorseRouterTree.RegisterMiddleware(const AMiddleware: THorseCallback); 269 | begin 270 | FMiddleware.Add(AMiddleware); 271 | end; 272 | 273 | procedure THorseRouterTree.RegisterMiddleware(const APath: string; const AMiddleware: THorseCallback); 274 | var 275 | LPathChain: TQueue; 276 | begin 277 | LPathChain := GetQueuePath(APath); 278 | try 279 | RegisterMiddlewareInternal(LPathChain, AMiddleware); 280 | finally 281 | LPathChain.Free; 282 | end; 283 | end; 284 | 285 | procedure THorseRouterTree.RegisterMiddlewareInternal(var APath: TQueue; const AMiddleware: THorseCallback); 286 | begin 287 | APath.Dequeue; 288 | if APath.Count = 0 then 289 | FMiddleware.Add(AMiddleware) 290 | else 291 | ForcePath(APath.Peek).RegisterMiddlewareInternal(APath, AMiddleware); 292 | end; 293 | 294 | end. -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Core.Route.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Core.Route; 2 | 3 | {$IF DEFINED(FPC)} 4 | {$MODE DELPHI}{$H+} 5 | {$ENDIF} 6 | 7 | interface 8 | 9 | uses 10 | {$IF DEFINED(FPC)} 11 | SysUtils, 12 | {$ELSE} 13 | System.SysUtils, 14 | {$ENDIF} 15 | Horse.Core.Route.Contract, Horse.Core.RouterTree, Horse.Callback; 16 | 17 | type 18 | THorseCoreRoute = class(TInterfacedObject, IHorseCoreRoute) 19 | private 20 | FPath: string; 21 | FHorseCore: TObject; 22 | public 23 | constructor Create(const APath: string); 24 | 25 | function This: IHorseCoreRoute; 26 | function AddCallback(const ACallback: THorseCallback): IHorseCoreRoute; 27 | function AddCallbacks(const ACallbacks: TArray): IHorseCoreRoute; 28 | 29 | function All(const ACallback: THorseCallback): IHorseCoreRoute; overload; 30 | function All(const AMiddleware, ACallback: THorseCallback): IHorseCoreRoute; overload; 31 | function All(const ACallbacks: array of THorseCallback): IHorseCoreRoute; overload; 32 | function All(const ACallbacks: array of THorseCallback; const ACallback: THorseCallback): IHorseCoreRoute; overload; 33 | 34 | function Get(const ACallback: THorseCallback): IHorseCoreRoute; overload; 35 | function Get(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 36 | function Get(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 37 | {$IFNDEF FPC} 38 | function Get(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 39 | {$IFEND} 40 | 41 | function Put(const ACallback: THorseCallback): IHorseCoreRoute; overload; 42 | function Put(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 43 | function Put(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 44 | {$IFNDEF FPC} 45 | function Put(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 46 | {$IFEND} 47 | 48 | function Head(const ACallback: THorseCallback): IHorseCoreRoute; overload; 49 | function Head(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 50 | function Head(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 51 | {$IFNDEF FPC} 52 | function Head(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 53 | {$IFEND} 54 | 55 | function Post(const ACallback: THorseCallback): IHorseCoreRoute; overload; 56 | function Post(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 57 | function Post(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 58 | {$IFNDEF FPC} 59 | function Post(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 60 | {$IFEND} 61 | 62 | {$IF (DEFINED(FPC) OR (CompilerVersion > 27.0))} 63 | function Patch(const ACallback: THorseCallback): IHorseCoreRoute; overload; 64 | function Delete(const ACallback: THorseCallback): IHorseCoreRoute; overload; 65 | 66 | function Patch(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 67 | function Patch(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 68 | {$IFNDEF FPC} 69 | function Patch(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 70 | {$IFEND} 71 | 72 | function Delete(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; overload; 73 | function Delete(const ACallback: THorseCallbackRequest): IHorseCoreRoute; overload; 74 | {$IFNDEF FPC} 75 | function Delete(const ACallback: THorseCallbackResponse): IHorseCoreRoute; overload; 76 | {$IFEND} 77 | {$IFEND} 78 | 79 | function &End: T; 80 | end; 81 | 82 | implementation 83 | 84 | uses Horse.Core; 85 | 86 | constructor THorseCoreRoute.Create(const APath: string); 87 | begin 88 | FPath := APath; 89 | FHorseCore := THorseCore.GetInstance; 90 | end; 91 | 92 | function THorseCoreRoute.This: IHorseCoreRoute; 93 | begin 94 | Result := Self; 95 | end; 96 | 97 | function THorseCoreRoute.All(const ACallback: THorseCallback): IHorseCoreRoute; 98 | begin 99 | Result := Self; 100 | THorseCore(FHorseCore).Use(FPath, ACallback); 101 | end; 102 | 103 | function THorseCoreRoute.All(const AMiddleware, ACallback: THorseCallback): IHorseCoreRoute; 104 | begin 105 | Result := Self; 106 | THorseCore(FHorseCore).Use(FPath, [AMiddleware, ACallback]); 107 | end; 108 | 109 | function THorseCoreRoute.All(const ACallbacks: array of THorseCallback): IHorseCoreRoute; 110 | begin 111 | Result := Self; 112 | THorseCore(FHorseCore).Use(FPath, ACallbacks); 113 | end; 114 | 115 | function THorseCoreRoute.&End: T; 116 | begin 117 | Result := FHorseCore as T; 118 | end; 119 | 120 | function THorseCoreRoute.AddCallback(const ACallback: THorseCallback): IHorseCoreRoute; 121 | begin 122 | Result := Self; 123 | THorseCore(FHorseCore).AddCallback(ACallback); 124 | end; 125 | 126 | function THorseCoreRoute.All(const ACallbacks: array of THorseCallback; const ACallback: THorseCallback): IHorseCoreRoute; 127 | begin 128 | Result := Self; 129 | THorseCore(FHorseCore).Use(FPath, ACallbacks); 130 | THorseCore(FHorseCore).Use(FPath, [ACallback]); 131 | end; 132 | 133 | {$IF (DEFINED(FPC) OR (CompilerVersion > 27.0))} 134 | function THorseCoreRoute.Delete(const ACallback: THorseCallback): IHorseCoreRoute; 135 | begin 136 | Result := Self; 137 | THorseCore(FHorseCore).Delete(FPath, ACallback); 138 | end; 139 | 140 | function THorseCoreRoute.Patch(const ACallback: THorseCallback): IHorseCoreRoute; 141 | begin 142 | Result := Self; 143 | THorseCore(FHorseCore).Patch(FPath, ACallback); 144 | end; 145 | 146 | function THorseCoreRoute.Delete(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; 147 | begin 148 | THorseCore(FHorseCore).Delete(FPath, ACallback); 149 | Result := Self; 150 | end; 151 | 152 | function THorseCoreRoute.Delete(const ACallback: THorseCallbackRequest): IHorseCoreRoute; 153 | begin 154 | THorseCore(FHorseCore).Delete(FPath, ACallback); 155 | Result := Self; 156 | end; 157 | 158 | {$IFNDEF FPC} 159 | function THorseCoreRoute.Delete(const ACallback: THorseCallbackResponse): IHorseCoreRoute; 160 | begin 161 | THorseCore(FHorseCore).Delete(FPath, ACallback); 162 | Result := Self; 163 | end; 164 | {$IFEND} 165 | 166 | function THorseCoreRoute.Patch(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; 167 | begin 168 | THorseCore(FHorseCore).Patch(FPath, ACallback); 169 | Result := Self; 170 | end; 171 | 172 | function THorseCoreRoute.Patch(const ACallback: THorseCallbackRequest): IHorseCoreRoute; 173 | begin 174 | THorseCore(FHorseCore).Patch(FPath, ACallback); 175 | Result := Self; 176 | end; 177 | 178 | {$IFNDEF FPC} 179 | function THorseCoreRoute.Patch(const ACallback: THorseCallbackResponse): IHorseCoreRoute; 180 | begin 181 | THorseCore(FHorseCore).Patch(FPath, ACallback); 182 | Result := Self; 183 | end; 184 | {$IFEND} 185 | {$IFEND} 186 | 187 | function THorseCoreRoute.Get(const ACallback: THorseCallback): IHorseCoreRoute; 188 | begin 189 | Result := Self; 190 | THorseCore(FHorseCore).Get(FPath, ACallback); 191 | end; 192 | 193 | function THorseCoreRoute.Head(const ACallback: THorseCallback): IHorseCoreRoute; 194 | begin 195 | Result := Self; 196 | THorseCore(FHorseCore).Head(FPath, ACallback); 197 | end; 198 | 199 | function THorseCoreRoute.Post(const ACallback: THorseCallback): IHorseCoreRoute; 200 | begin 201 | Result := Self; 202 | THorseCore(FHorseCore).Post(FPath, ACallback); 203 | end; 204 | 205 | function THorseCoreRoute.Put(const ACallback: THorseCallback): IHorseCoreRoute; 206 | begin 207 | Result := Self; 208 | THorseCore(FHorseCore).Put(FPath, ACallback); 209 | end; 210 | 211 | function THorseCoreRoute.AddCallbacks(const ACallbacks: TArray): IHorseCoreRoute; 212 | var 213 | LCallback: THorseCallback; 214 | begin 215 | for LCallback in ACallbacks do 216 | AddCallback(LCallback); 217 | Result := Self; 218 | end; 219 | 220 | function THorseCoreRoute.Get(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; 221 | begin 222 | THorseCore(FHorseCore).Get(FPath, ACallback); 223 | Result := Self; 224 | end; 225 | 226 | function THorseCoreRoute.Get(const ACallback: THorseCallbackRequest): IHorseCoreRoute; 227 | begin 228 | THorseCore(FHorseCore).Get(FPath, ACallback); 229 | Result := Self; 230 | end; 231 | 232 | {$IFNDEF FPC} 233 | function THorseCoreRoute.Get(const ACallback: THorseCallbackResponse): IHorseCoreRoute; 234 | begin 235 | THorseCore(FHorseCore).Get(FPath, ACallback); 236 | Result := Self; 237 | end; 238 | {$IFEND} 239 | 240 | function THorseCoreRoute.Head(const ACallback: THorseCallbackRequest): IHorseCoreRoute; 241 | begin 242 | THorseCore(FHorseCore).Head(FPath, ACallback); 243 | Result := Self; 244 | end; 245 | 246 | function THorseCoreRoute.Head(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; 247 | begin 248 | THorseCore(FHorseCore).Head(FPath, ACallback); 249 | Result := Self; 250 | end; 251 | 252 | {$IFNDEF FPC} 253 | function THorseCoreRoute.Head(const ACallback: THorseCallbackResponse): IHorseCoreRoute; 254 | begin 255 | THorseCore(FHorseCore).Head(FPath, ACallback); 256 | Result := Self; 257 | end; 258 | {$IFEND} 259 | 260 | function THorseCoreRoute.Post(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; 261 | begin 262 | THorseCore(FHorseCore).Post(FPath, ACallback); 263 | Result := Self; 264 | end; 265 | 266 | function THorseCoreRoute.Post(const ACallback: THorseCallbackRequest): IHorseCoreRoute; 267 | begin 268 | THorseCore(FHorseCore).Post(FPath, ACallback); 269 | Result := Self; 270 | end; 271 | 272 | {$IFNDEF FPC} 273 | function THorseCoreRoute.Post(const ACallback: THorseCallbackResponse): IHorseCoreRoute; 274 | begin 275 | THorseCore(FHorseCore).Post(FPath, ACallback); 276 | Result := Self; 277 | end; 278 | {$IFEND} 279 | 280 | {$IFNDEF FPC} 281 | function THorseCoreRoute.Put(const ACallback: THorseCallbackResponse): IHorseCoreRoute; 282 | begin 283 | THorseCore(FHorseCore).Put(FPath, ACallback); 284 | Result := Self; 285 | end; 286 | {$IFEND} 287 | 288 | function THorseCoreRoute.Put(const ACallback: THorseCallbackRequest): IHorseCoreRoute; 289 | begin 290 | THorseCore(FHorseCore).Put(FPath, ACallback); 291 | Result := Self; 292 | end; 293 | 294 | function THorseCoreRoute.Put(const ACallback: THorseCallbackRequestResponse): IHorseCoreRoute; 295 | begin 296 | THorseCore(FHorseCore).Put(FPath, ACallback); 297 | Result := Self; 298 | end; 299 | 300 | end. 301 | -------------------------------------------------------------------------------- /Samples/Horse/Horse/src/Horse.Provider.VCL.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.VCL; 2 | 3 | interface 4 | 5 | {$IF DEFINED(HORSE_VCL)} 6 | uses Horse.Provider.Abstract, Horse.Constants, Horse.Provider.IOHandleSSL, IdHTTPWebBrokerBridge, IdSSLOpenSSL, IdContext, 7 | System.Classes, System.SyncObjs, System.SysUtils; 8 | 9 | type 10 | THorseProvider = class(THorseProviderAbstract) 11 | private 12 | class var FPort: Integer; 13 | class var FHost: string; 14 | class var FRunning: Boolean; 15 | class var FEvent: TEvent; 16 | class var FMaxConnections: Integer; 17 | class var FListenQueue: Integer; 18 | class var FIdHTTPWebBrokerBridge: TIdHTTPWebBrokerBridge; 19 | class var FHorseProviderIOHandleSSL: THorseProviderIOHandleSSL; 20 | class function GetDefaultHTTPWebBroker: TIdHTTPWebBrokerBridge; 21 | class function GetDefaultHorseProviderIOHandleSSL: THorseProviderIOHandleSSL; 22 | class function GetDefaultEvent: TEvent; 23 | class function HTTPWebBrokerIsNil: Boolean; 24 | class procedure OnAuthentication(AContext: TIdContext; const AAuthType, AAuthData: string; var VUsername, VPassword: string; var VHandled: Boolean); 25 | class procedure OnQuerySSLPort(APort: Word; var VUseSSL: Boolean); 26 | class procedure SetListenQueue(const AValue: Integer); static; 27 | class procedure SetMaxConnections(const AValue: Integer); static; 28 | class procedure SetPort(const AValue: Integer); static; 29 | class procedure SetIOHandleSSL(const AValue: THorseProviderIOHandleSSL); static; 30 | class procedure SetHost(const AValue: string); static; 31 | class function GetListenQueue: Integer; static; 32 | class function GetMaxConnections: Integer; static; 33 | class function GetPort: Integer; static; 34 | class function GetDefaultPort: Integer; static; 35 | class function GetDefaultHost: string; static; 36 | class function GetIOHandleSSL: THorseProviderIOHandleSSL; static; 37 | class function GetHost: string; static; 38 | class procedure InternalListen; virtual; 39 | class procedure InternalStopListen; virtual; 40 | class procedure InitServerIOHandlerSSLOpenSSL(const AIdHTTPWebBrokerBridge: TIdHTTPWebBrokerBridge; const AHorseProviderIOHandleSSL: THorseProviderIOHandleSSL); 41 | public 42 | class property Host: string read GetHost write SetHost; 43 | class property Port: Integer read GetPort write SetPort; 44 | class property MaxConnections: Integer read GetMaxConnections write SetMaxConnections; 45 | class property ListenQueue: Integer read GetListenQueue write SetListenQueue; 46 | class property IOHandleSSL: THorseProviderIOHandleSSL read GetIOHandleSSL write SetIOHandleSSL; 47 | class procedure StopListen; override; 48 | class procedure Listen; overload; override; 49 | class procedure Listen(const APort: Integer; const AHost: string = '0.0.0.0'; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 50 | class procedure Listen(const APort: Integer; const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 51 | class procedure Listen(const AHost: string; const ACallbackListen: TProc = nil; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 52 | class procedure Listen(const ACallbackListen: TProc; const ACallbackStopListen: TProc = nil); reintroduce; overload; static; 53 | class function IsRunning: Boolean; 54 | class destructor UnInitialize; 55 | end; 56 | {$ENDIF} 57 | 58 | implementation 59 | 60 | {$IF DEFINED(HORSE_VCL)} 61 | uses Web.WebReq, Horse.WebModule, IdCustomTCPServer; 62 | 63 | class function THorseProvider.IsRunning: Boolean; 64 | begin 65 | Result := FRunning; 66 | end; 67 | 68 | class function THorseProvider.GetDefaultHTTPWebBroker: TIdHTTPWebBrokerBridge; 69 | begin 70 | if HTTPWebBrokerIsNil then 71 | begin 72 | FIdHTTPWebBrokerBridge := TIdHTTPWebBrokerBridge.Create(nil); 73 | FIdHTTPWebBrokerBridge.OnParseAuthentication := OnAuthentication; 74 | FIdHTTPWebBrokerBridge.OnQuerySSLPort := OnQuerySSLPort; 75 | end; 76 | Result := FIdHTTPWebBrokerBridge; 77 | end; 78 | 79 | class function THorseProvider.HTTPWebBrokerIsNil: Boolean; 80 | begin 81 | Result := FIdHTTPWebBrokerBridge = nil; 82 | end; 83 | 84 | class procedure THorseProvider.OnQuerySSLPort(APort: Word; var VUseSSL: Boolean); 85 | begin 86 | VUseSSL := (FHorseProviderIOHandleSSL <> nil) and (FHorseProviderIOHandleSSL.Active); 87 | end; 88 | 89 | class function THorseProvider.GetDefaultEvent: TEvent; 90 | begin 91 | if FEvent = nil then 92 | FEvent := TEvent.Create; 93 | Result := FEvent; 94 | end; 95 | 96 | class function THorseProvider.GetDefaultHorseProviderIOHandleSSL: THorseProviderIOHandleSSL; 97 | begin 98 | if FHorseProviderIOHandleSSL = nil then 99 | FHorseProviderIOHandleSSL := THorseProviderIOHandleSSL.Create; 100 | Result := FHorseProviderIOHandleSSL; 101 | end; 102 | 103 | class function THorseProvider.GetDefaultHost: string; 104 | begin 105 | Result := DEFAULT_HOST; 106 | end; 107 | 108 | class function THorseProvider.GetDefaultPort: Integer; 109 | begin 110 | Result := DEFAULT_PORT; 111 | end; 112 | 113 | class function THorseProvider.GetHost: string; 114 | begin 115 | Result := FHost; 116 | end; 117 | 118 | class function THorseProvider.GetIOHandleSSL: THorseProviderIOHandleSSL; 119 | begin 120 | Result := GetDefaultHorseProviderIOHandleSSL; 121 | end; 122 | 123 | class function THorseProvider.GetListenQueue: Integer; 124 | begin 125 | Result := FListenQueue; 126 | end; 127 | 128 | class function THorseProvider.GetMaxConnections: Integer; 129 | begin 130 | Result := FMaxConnections; 131 | end; 132 | 133 | class function THorseProvider.GetPort: Integer; 134 | begin 135 | Result := FPort; 136 | end; 137 | 138 | class procedure THorseProvider.InitServerIOHandlerSSLOpenSSL(const AIdHTTPWebBrokerBridge: TIdHTTPWebBrokerBridge; const AHorseProviderIOHandleSSL: THorseProviderIOHandleSSL); 139 | var 140 | LIOHandleSSL: TIdServerIOHandlerSSLOpenSSL; 141 | begin 142 | LIOHandleSSL := TIdServerIOHandlerSSLOpenSSL.Create(AIdHTTPWebBrokerBridge); 143 | LIOHandleSSL.SSLOptions.CertFile := AHorseProviderIOHandleSSL.CertFile; 144 | LIOHandleSSL.SSLOptions.RootCertFile := AHorseProviderIOHandleSSL.RootCertFile; 145 | LIOHandleSSL.SSLOptions.KeyFile := AHorseProviderIOHandleSSL.KeyFile; 146 | LIOHandleSSL.SSLOptions.Method := AHorseProviderIOHandleSSL.Method; 147 | LIOHandleSSL.SSLOptions.SSLVersions := AHorseProviderIOHandleSSL.SSLVersions; 148 | LIOHandleSSL.OnGetPassword := AHorseProviderIOHandleSSL.OnGetPassword; 149 | AIdHTTPWebBrokerBridge.IOHandler := LIOHandleSSL; 150 | end; 151 | 152 | class procedure THorseProvider.InternalListen; 153 | var 154 | LAttach: string; 155 | LIdHTTPWebBrokerBridge: TIdHTTPWebBrokerBridge; 156 | begin 157 | inherited; 158 | if FPort <= 0 then 159 | FPort := GetDefaultPort; 160 | if FHost.IsEmpty then 161 | FHost := GetDefaultHost; 162 | 163 | LIdHTTPWebBrokerBridge := GetDefaultHTTPWebBroker; 164 | WebRequestHandler.WebModuleClass := WebModuleClass; 165 | try 166 | if FMaxConnections > 0 then 167 | begin 168 | WebRequestHandler.MaxConnections := FMaxConnections; 169 | GetDefaultHTTPWebBroker.MaxConnections := FMaxConnections; 170 | end; 171 | 172 | if FListenQueue = 0 then 173 | FListenQueue := IdListenQueueDefault; 174 | 175 | if FHorseProviderIOHandleSSL <> nil then 176 | InitServerIOHandlerSSLOpenSSL(LIdHTTPWebBrokerBridge, GetDefaultHorseProviderIOHandleSSL); 177 | 178 | LIdHTTPWebBrokerBridge.ListenQueue := FListenQueue; 179 | 180 | LIdHTTPWebBrokerBridge.Bindings.Clear; 181 | if FHost <> GetDefaultHost then 182 | begin 183 | LIdHTTPWebBrokerBridge.Bindings.Add; 184 | LIdHTTPWebBrokerBridge.Bindings.Items[0].IP := FHost; 185 | LIdHTTPWebBrokerBridge.Bindings.Items[0].Port := FPort; 186 | end; 187 | 188 | LIdHTTPWebBrokerBridge.DefaultPort := FPort; 189 | LIdHTTPWebBrokerBridge.Active := True; 190 | LIdHTTPWebBrokerBridge.StartListening; 191 | FRunning := True; 192 | DoOnListen; 193 | except 194 | raise; 195 | end; 196 | end; 197 | 198 | class procedure THorseProvider.InternalStopListen; 199 | begin 200 | if not HTTPWebBrokerIsNil then 201 | begin 202 | GetDefaultHTTPWebBroker.StopListening; 203 | GetDefaultHTTPWebBroker.Active := False; 204 | DoOnStopListen; 205 | FRunning := False; 206 | if FEvent <> nil then 207 | GetDefaultEvent.SetEvent; 208 | end 209 | else 210 | raise Exception.Create('Horse not listen'); 211 | end; 212 | 213 | class procedure THorseProvider.StopListen; 214 | begin 215 | InternalStopListen; 216 | end; 217 | 218 | class procedure THorseProvider.Listen; 219 | begin 220 | InternalListen; 221 | end; 222 | 223 | class procedure THorseProvider.Listen(const APort: Integer; const AHost: string; const ACallbackListen, ACallbackStopListen: TProc); 224 | begin 225 | SetPort(APort); 226 | SetHost(AHost); 227 | SetOnListen(ACallbackListen); 228 | SetOnStopListen(ACallbackStopListen); 229 | InternalListen; 230 | end; 231 | 232 | class procedure THorseProvider.Listen(const AHost: string; const ACallbackListen, ACallbackStopListen: TProc); 233 | begin 234 | Listen(FPort, AHost, ACallbackListen, ACallbackStopListen); 235 | end; 236 | 237 | class procedure THorseProvider.Listen(const ACallbackListen, ACallbackStopListen: TProc); 238 | begin 239 | Listen(FPort, FHost, ACallbackListen, ACallbackStopListen); 240 | end; 241 | 242 | class procedure THorseProvider.Listen(const APort: Integer; const ACallbackListen, ACallbackStopListen: TProc); 243 | begin 244 | Listen(APort, FHost, ACallbackListen, ACallbackStopListen); 245 | end; 246 | 247 | class procedure THorseProvider.OnAuthentication(AContext: TIdContext; const AAuthType, AAuthData: string; var VUsername, VPassword: string; var VHandled: Boolean); 248 | begin 249 | VHandled := True; 250 | end; 251 | 252 | class procedure THorseProvider.SetHost(const AValue: string); 253 | begin 254 | FHost := AValue.Trim; 255 | end; 256 | 257 | class procedure THorseProvider.SetIOHandleSSL(const AValue: THorseProviderIOHandleSSL); 258 | begin 259 | FHorseProviderIOHandleSSL := AValue; 260 | end; 261 | 262 | class procedure THorseProvider.SetListenQueue(const AValue: Integer); 263 | begin 264 | FListenQueue := AValue; 265 | end; 266 | 267 | class procedure THorseProvider.SetMaxConnections(const AValue: Integer); 268 | begin 269 | FMaxConnections := AValue; 270 | end; 271 | 272 | class procedure THorseProvider.SetPort(const AValue: Integer); 273 | begin 274 | FPort := AValue; 275 | end; 276 | 277 | class destructor THorseProvider.UnInitialize; 278 | begin 279 | FreeAndNil(FIdHTTPWebBrokerBridge); 280 | if FEvent <> nil then 281 | FreeAndNil(FEvent); 282 | if FHorseProviderIOHandleSSL <> nil then 283 | FreeAndNil(FHorseProviderIOHandleSSL); 284 | end; 285 | {$ENDIF} 286 | 287 | end. 288 | --------------------------------------------------------------------------------