├── .gitignore ├── FastReportPrinter.groupproj ├── LICENSE ├── README.md ├── Samples ├── CGI │ ├── CGI.dpr │ ├── CGI.dproj │ ├── CGI.res │ └── Readme.txt ├── Console │ ├── Console.dpr │ ├── Console.dproj │ └── Console.res ├── ConsoleHorse │ ├── ConsoleHorse.dpr │ ├── ConsoleHorse.dproj │ ├── ConsoleHorse.res │ └── Readme.txt ├── DB │ └── FAST_REPORT_PRINTER.FDB ├── FMX │ ├── FMX.dpr │ ├── FMX.dproj │ ├── FMX.res │ ├── Main.fmx │ └── Main.pas ├── Horse │ ├── Horse │ │ └── src │ │ │ ├── Horse.Callback.pas │ │ │ ├── Horse.Commons.pas │ │ │ ├── Horse.Constants.pas │ │ │ ├── Horse.Core.Files.pas │ │ │ ├── Horse.Core.Group.Contract.pas │ │ │ ├── Horse.Core.Group.pas │ │ │ ├── Horse.Core.Param.Config.pas │ │ │ ├── Horse.Core.Param.Field.Brackets.pas │ │ │ ├── Horse.Core.Param.Field.pas │ │ │ ├── Horse.Core.Param.Header.pas │ │ │ ├── Horse.Core.Param.pas │ │ │ ├── Horse.Core.Route.Contract.pas │ │ │ ├── Horse.Core.Route.pas │ │ │ ├── Horse.Core.RouterTree.NextCaller.pas │ │ │ ├── Horse.Core.RouterTree.pas │ │ │ ├── Horse.Core.pas │ │ │ ├── Horse.Exception.Interrupted.pas │ │ │ ├── Horse.Exception.pas │ │ │ ├── Horse.Proc.pas │ │ │ ├── Horse.Provider.Abstract.pas │ │ │ ├── Horse.Provider.Apache.pas │ │ │ ├── Horse.Provider.CGI.pas │ │ │ ├── Horse.Provider.Console.pas │ │ │ ├── Horse.Provider.Daemon.pas │ │ │ ├── Horse.Provider.FPC.Apache.pas │ │ │ ├── Horse.Provider.FPC.CGI.pas │ │ │ ├── Horse.Provider.FPC.Daemon.pas │ │ │ ├── Horse.Provider.FPC.FastCGI.pas │ │ │ ├── Horse.Provider.FPC.HTTPApplication.pas │ │ │ ├── Horse.Provider.FPC.LCL.pas │ │ │ ├── Horse.Provider.IOHandleSSL.pas │ │ │ ├── Horse.Provider.ISAPI.pas │ │ │ ├── Horse.Provider.VCL.pas │ │ │ ├── Horse.Request.pas │ │ │ ├── Horse.Response.pas │ │ │ ├── Horse.Rtti.Helper.pas │ │ │ ├── Horse.Rtti.pas │ │ │ ├── Horse.Session.pas │ │ │ ├── Horse.WebModule.dfm │ │ │ ├── Horse.WebModule.lfm │ │ │ ├── Horse.WebModule.pas │ │ │ ├── Horse.pas │ │ │ ├── ThirdParty.Posix.Syslog.pas │ │ │ └── Web.WebConst.pas │ └── Staticfiles │ │ └── src │ │ └── Horse.StaticFiles.pas ├── ISAPI │ ├── ISAPI.dpr │ ├── ISAPI.dproj │ ├── ISAPI.res │ └── Readme.txt ├── JMeter │ └── FastReportPrinter.jmx ├── Postman │ └── FastReportPrinter.postman_collection_v2.1.json ├── Report │ └── rptLocalidadesIBGE.fr3 ├── Utils │ ├── Data.pas │ └── Utils.pas ├── VCL │ ├── Main.dfm │ ├── Main.pas │ ├── Samples.res │ ├── VCL.dpr │ ├── VCL.dproj │ └── VCL.res ├── VCLHorse │ ├── Main.dfm │ ├── Main.pas │ ├── Readme.txt │ ├── VCLHorse.dpr │ ├── VCLHorse.dproj │ └── VCLHorse.res ├── WindowsService │ ├── Main.dfm │ ├── Main.pas │ ├── WindowsServer.res │ ├── WindowsService.dpr │ ├── WindowsService.dproj │ └── WindowsService.res └── WindowsServiceHorse │ ├── Main.dfm │ ├── Main.pas │ ├── Readme.txt │ ├── WindowsServiceHorse.dpr │ ├── WindowsServiceHorse.dproj │ └── WindowsServiceHorse.res ├── Source ├── FRPrinter.Core.pas ├── FRPrinter.Interfaces.pas ├── FRPrinter.Types.pas └── FRPrinter.pas ├── boss-lock.json └── boss.json /.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 | -------------------------------------------------------------------------------- /FastReportPrinter.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 | Default.Personality.12 36 | 37 | 38 | 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 | -------------------------------------------------------------------------------- /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/FastReportPrinter?label=Latest%20release&style=flat-square&color=important) 4 | ![Stars](https://img.shields.io/github/stars/antoniojmsjr/FastReportPrinter.svg?style=flat-square) 5 | ![Forks](https://img.shields.io/github/forks/antoniojmsjr/FastReportPrinter.svg?style=flat-square) 6 | ![Issues](https://img.shields.io/github/issues/antoniojmsjr/FastReportPrinter.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%20above-3db36a?style=flat-square) 9 | ![FastReport Supported Versions](https://img.shields.io/badge/Fast%20Report%20Supported%20Versions-5.1.5%20and%20above-3db36a?style=flat-square) 10 | 11 | # FastReportPrinter 12 | 13 | **FastReportPrinter** é uma biblioteca de impressã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 impressão de relatórios em ambientes não GUI(Graphical User Interface) usando spooler de impressão. 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 **FastReportPrinter** é 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/FastReportPrinter 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 | ..\FastReportPrinter\Source 43 | ``` 44 | 45 | ## 🧬 DataSet de Exportação 46 | 47 | **DataSets** é uma interface utilizada pela biblioteca para comunicação com o banco de dados através dos componentes: 48 | 49 | | Classe | Componente | 50 | |---|---| 51 | | TDataSet | Nativo | 52 | | TfrxDBDataset | Fast Report | 53 | 54 | ## ⚡️ Uso da biblioteca 55 | 56 | 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 impressão do relatório. 57 | 58 | Arquivo de exemplo de impressão: [LocalidadesIBGE.pdf](https://github.com/antoniojmsjr/FastReportPrinter/files/9245473/LocalidadesIBGE.pdf) 59 | 60 | Os exemplos estão disponíveis na pasta do projeto: 61 | 62 | ``` 63 | ..\FastReportPrinter\Samples 64 | ``` 65 | 66 | **Banco de dados de exemplo** 67 | 68 | * 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) 69 | * Arquivo BD: 70 | ``` 71 | ..\FastReportPrinter\Samples\DB 72 | ``` 73 | 74 | **Relatório de exemplo** 75 | 76 | ``` 77 | ..\FastReportPrinter\Samples\Report 78 | ``` 79 | **Exemplo** 80 | 81 | ```delphi 82 | uses FRPrinter, FRPrinter.Types; 83 | ``` 84 | ```delphi 85 | var 86 | lPrinted: Boolean; 87 | begin 88 | 89 | //CLASSE DE IMPRESSÃO 90 | try 91 | lPrinted := TFRPrinter.New. 92 | DataSets. 93 | SetDataSet(qryEstadosBrasil, 'EstadosBrasil'). 94 | SetDataSet(frxdbMunicipioEstado). 95 | SetDataSet(frxdbMunicipioRegiao). 96 | SetDataSet(qryEstadoRegiao, 'EstadoRegiao'). 97 | SetDataSet(qryMunicipios, 'Municipios'). 98 | &End. 99 | Print. 100 | SetPrinter('Microsoft Print to PDF'). //QUANDO NÃO INFORMADO UTILIZA A IMPRESSORA CONFIGURADA NO RELATÓRIO *.fr3 101 | SetFileReport(TUtils.PathAppFileReport). //LOCAL DO RELATÓRIO *.fr3 102 | Report(procedure(pfrxReport: TfrxReport) //CONFIGURAÇÃO DO COMPONENTE DE RELATÓRIO DO FAST REPORT 103 | var 104 | lfrxComponent: TfrxComponent; 105 | lfrxMemoView: TfrxMemoView absolute lfrxComponent; 106 | begin 107 | //CONFIGURAÇÃO DO COMPONENTE 108 | 109 | pfrxReport.ReportOptions.Name := 'API de localidades IBGE'; //NOME PARA IDENTIFICAÇÃO NA IMPRESSÃO DO RELATÓRIO 110 | pfrxReport.ReportOptions.Author := 'Antônio José Medeiros Schneider'; 111 | 112 | //PASSAGEM DE PARÂMETRO PARA O RELATÓRIO 113 | lfrxComponent := pfrxReport.FindObject('mmoProcess'); 114 | if Assigned(lfrxComponent) then 115 | begin 116 | lfrxMemoView.Memo.Clear; 117 | lfrxMemoView.Memo.Text := Format('Aplicativo de Exemplo: %s', ['VCL']); 118 | end; 119 | end). 120 | Execute; //PROCESSAMENTO DO RELATÓRIO/IMPRESSÃO 121 | except 122 | on E: Exception do 123 | begin 124 | if E is EFRPrinter then 125 | ShowMessage('Erro de impressão: ' + E.ToString) 126 | else 127 | ShowMessage('Erro de impressão: ' + E.Message); 128 | Exit; 129 | end; 130 | end; 131 | 132 | if lPrinted then 133 | ShowMessage('Impresso') 134 | else 135 | ShowMessage('Falha de impressão'); 136 | 137 | end; 138 | ``` 139 | 140 | **Observação** 141 | 142 | * Falta de memória pode gerar falha de impressão. 143 | * Impressão de documento grande pode ter demora na resposta de sucesso da impressão. 144 | * Windows Service Application é necessário configurar "logon" usando uma conta administrativa ou NT AUTHORITY\LocalService e ou NT AUTHORITY\NetworkService para uma impressão com sucesso. 145 | * IIS(ISAPI/CGI) devido a um [bug](https://blogs.stonesteps.ca/1/p/44) quando app 32 bits e Windows 64 bits não é possível imprimir, solução, compilar app 64 bits e com permissão usando uma conta NT AUTHORITY\LocalService e ou NT AUTHORITY\NetworkService. 146 | 147 | **Exemplo compilado** 148 | 149 | * VCL 150 | * VCL [(Horse)](https://github.com/HashLoad/horse) 151 | 152 | Download: [Demo.zip](https://github.com/antoniojmsjr/FastReportPrinter/files/9245293/Demo.zip) 153 | 154 | 155 | 156 | https://user-images.githubusercontent.com/20980984/183212903-ec64169a-f1f5-4c21-8c46-bc3e5a8c8078.mp4 157 | 158 | 159 | 160 | https://user-images.githubusercontent.com/20980984/183213069-68c4ca35-4804-481e-854e-e7d1ae303686.mp4 161 | 162 | 163 | 164 | **Teste de desempenho para aplicações web usando [JMeter](https://jmeter.apache.org/):** 165 | 166 | ``` 167 | ..\FastReportPrinter\Samples\JMeter 168 | ``` 169 | 170 | 171 | ## ⚠️ Licença 172 | `FastReportPrinter` is free and open-source software licensed under the [![License](https://img.shields.io/badge/license-Apache%202-blue.svg)](https://github.com/antoniojmsjr/FastReportPrinter/blob/main/LICENSE) 173 | -------------------------------------------------------------------------------- /Samples/CGI/CGI.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/CGI/CGI.dpr -------------------------------------------------------------------------------- /Samples/CGI/CGI.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/CGI/CGI.res -------------------------------------------------------------------------------- /Samples/CGI/Readme.txt: -------------------------------------------------------------------------------- 1 | Samples with Horse 2 | 3 | https://github.com/HashLoad/horse -------------------------------------------------------------------------------- /Samples/Console/Console.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/Console/Console.dpr -------------------------------------------------------------------------------- /Samples/Console/Console.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/Console/Console.res -------------------------------------------------------------------------------- /Samples/ConsoleHorse/ConsoleHorse.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/ConsoleHorse/ConsoleHorse.dpr -------------------------------------------------------------------------------- /Samples/ConsoleHorse/ConsoleHorse.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/ConsoleHorse/ConsoleHorse.res -------------------------------------------------------------------------------- /Samples/ConsoleHorse/Readme.txt: -------------------------------------------------------------------------------- 1 | Samples with Horse 2 | 3 | https://github.com/HashLoad/horse -------------------------------------------------------------------------------- /Samples/DB/FAST_REPORT_PRINTER.FDB: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/DB/FAST_REPORT_PRINTER.FDB -------------------------------------------------------------------------------- /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/FMX/FMX.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/FMX/FMX.res -------------------------------------------------------------------------------- /Samples/FMX/Main.fmx: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | Caption = 'Impress'#227'o Fast Report' 5 | ClientHeight = 50 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 btnImprimir: TButton 19 | Position.X = 15.000000000000000000 20 | Position.Y = 15.000000000000000000 21 | TabOrder = 1 22 | Text = 'Imprimir' 23 | OnClick = btnImprimirClick 24 | end 25 | object btnImprimirThread: 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 = 'Imprimir - Thread' 33 | OnClick = btnImprimirThreadClick 34 | end 35 | end 36 | end 37 | -------------------------------------------------------------------------------- /Samples/FMX/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/FMX/Main.pas -------------------------------------------------------------------------------- /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.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.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/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.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.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.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.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.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.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 | -------------------------------------------------------------------------------- /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.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.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.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.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.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.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/Horse/Horse/src/Horse.Provider.Console.pas: -------------------------------------------------------------------------------- 1 | unit Horse.Provider.Console; 2 | 3 | interface 4 | 5 | {$IF NOT DEFINED(FPC)} 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 NOT DEFINED(FPC)} 61 | uses Web.WebReq, Horse.WebModule, IdCustomTCPServer; 62 | 63 | class function THorseProvider.GetDefaultHTTPWebBroker: TIdHTTPWebBrokerBridge; 64 | begin 65 | if HTTPWebBrokerIsNil then 66 | begin 67 | FIdHTTPWebBrokerBridge := TIdHTTPWebBrokerBridge.Create(nil); 68 | FIdHTTPWebBrokerBridge.OnParseAuthentication := OnAuthentication; 69 | FIdHTTPWebBrokerBridge.OnQuerySSLPort := OnQuerySSLPort; 70 | end; 71 | Result := FIdHTTPWebBrokerBridge; 72 | end; 73 | 74 | class function THorseProvider.HTTPWebBrokerIsNil: Boolean; 75 | begin 76 | Result := FIdHTTPWebBrokerBridge = nil; 77 | end; 78 | 79 | class procedure THorseProvider.OnQuerySSLPort(APort: Word; var VUseSSL: Boolean); 80 | begin 81 | VUseSSL := (FHorseProviderIOHandleSSL <> nil) and (FHorseProviderIOHandleSSL.Active); 82 | end; 83 | 84 | class function THorseProvider.GetDefaultEvent: TEvent; 85 | begin 86 | if FEvent = nil then 87 | FEvent := TEvent.Create; 88 | Result := FEvent; 89 | end; 90 | 91 | class function THorseProvider.GetDefaultHorseProviderIOHandleSSL: THorseProviderIOHandleSSL; 92 | begin 93 | if FHorseProviderIOHandleSSL = nil then 94 | FHorseProviderIOHandleSSL := THorseProviderIOHandleSSL.Create; 95 | Result := FHorseProviderIOHandleSSL; 96 | end; 97 | 98 | class function THorseProvider.GetDefaultHost: string; 99 | begin 100 | Result := DEFAULT_HOST; 101 | end; 102 | 103 | class function THorseProvider.GetDefaultPort: Integer; 104 | begin 105 | Result := DEFAULT_PORT; 106 | end; 107 | 108 | class function THorseProvider.GetHost: string; 109 | begin 110 | Result := FHost; 111 | end; 112 | 113 | class function THorseProvider.IsRunning: Boolean; 114 | begin 115 | Result := FRunning; 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 | 161 | if FHost.IsEmpty then 162 | FHost := GetDefaultHost; 163 | 164 | LIdHTTPWebBrokerBridge := GetDefaultHTTPWebBroker; 165 | WebRequestHandler.WebModuleClass := WebModuleClass; 166 | try 167 | if FMaxConnections > 0 then 168 | begin 169 | WebRequestHandler.MaxConnections := FMaxConnections; 170 | GetDefaultHTTPWebBroker.MaxConnections := FMaxConnections; 171 | end; 172 | 173 | if FListenQueue = 0 then 174 | FListenQueue := IdListenQueueDefault; 175 | 176 | if FHorseProviderIOHandleSSL <> nil then 177 | InitServerIOHandlerSSLOpenSSL(LIdHTTPWebBrokerBridge, GetDefaultHorseProviderIOHandleSSL); 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 | 194 | if IsConsole then 195 | begin 196 | while FRunning do 197 | GetDefaultEvent.WaitFor(); 198 | end 199 | except 200 | on E: Exception do 201 | begin 202 | if IsConsole then 203 | begin 204 | Writeln(E.ClassName, ': ', E.Message); 205 | Read(LAttach); 206 | end 207 | else 208 | {$IF CompilerVersion >= 32.0} 209 | raise AcquireExceptionObject; 210 | {$ELSE} 211 | raise; 212 | {$ENDIF} 213 | end; 214 | end; 215 | end; 216 | 217 | class procedure THorseProvider.InternalStopListen; 218 | begin 219 | if not HTTPWebBrokerIsNil then 220 | begin 221 | GetDefaultHTTPWebBroker.StopListening; 222 | GetDefaultHTTPWebBroker.Active := False; 223 | DoOnStopListen; 224 | FRunning := False; 225 | if FEvent <> nil then 226 | GetDefaultEvent.SetEvent; 227 | end 228 | else 229 | raise Exception.Create('Horse not listen'); 230 | end; 231 | 232 | class procedure THorseProvider.StopListen; 233 | begin 234 | InternalStopListen; 235 | end; 236 | 237 | class procedure THorseProvider.Listen; 238 | begin 239 | InternalListen; 240 | end; 241 | 242 | class procedure THorseProvider.Listen(const APort: Integer; const AHost: string; const ACallbackListen, ACallbackStopListen: TProc); 243 | begin 244 | SetPort(APort); 245 | SetHost(AHost); 246 | SetOnListen(ACallbackListen); 247 | SetOnStopListen(ACallbackStopListen); 248 | InternalListen; 249 | end; 250 | 251 | class procedure THorseProvider.Listen(const AHost: string; const ACallbackListen, ACallbackStopListen: TProc); 252 | begin 253 | Listen(FPort, AHost, ACallbackListen, ACallbackStopListen); 254 | end; 255 | 256 | class procedure THorseProvider.Listen(const ACallbackListen, ACallbackStopListen: TProc); 257 | begin 258 | Listen(FPort, FHost, ACallbackListen, ACallbackStopListen); 259 | end; 260 | 261 | class procedure THorseProvider.Listen(const APort: Integer; const ACallbackListen, ACallbackStopListen: TProc); 262 | begin 263 | Listen(APort, FHost, ACallbackListen, ACallbackStopListen); 264 | end; 265 | 266 | class procedure THorseProvider.OnAuthentication(AContext: TIdContext; const AAuthType, AAuthData: String; var VUsername, VPassword: String; var VHandled: Boolean); 267 | begin 268 | VHandled := True; 269 | end; 270 | 271 | class procedure THorseProvider.SetHost(const AValue: string); 272 | begin 273 | FHost := AValue.Trim; 274 | end; 275 | 276 | class procedure THorseProvider.SetIOHandleSSL(const AValue: THorseProviderIOHandleSSL); 277 | begin 278 | FHorseProviderIOHandleSSL := AValue; 279 | end; 280 | 281 | class procedure THorseProvider.SetListenQueue(const AValue: Integer); 282 | begin 283 | FListenQueue := AValue; 284 | end; 285 | 286 | class procedure THorseProvider.SetMaxConnections(const AValue: Integer); 287 | begin 288 | FMaxConnections := AValue; 289 | end; 290 | 291 | class procedure THorseProvider.SetPort(const AValue: Integer); 292 | begin 293 | FPort := AValue; 294 | end; 295 | 296 | class destructor THorseProvider.UnInitialize; 297 | begin 298 | FreeAndNil(FIdHTTPWebBrokerBridge); 299 | if FEvent <> nil then 300 | FreeAndNil(FEvent); 301 | if FHorseProviderIOHandleSSL <> nil then 302 | FreeAndNil(FHorseProviderIOHandleSSL); 303 | end; 304 | {$ENDIF} 305 | 306 | end. 307 | -------------------------------------------------------------------------------- /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.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.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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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.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/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/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 | -------------------------------------------------------------------------------- /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.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.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/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 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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.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/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 | -------------------------------------------------------------------------------- /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/Horse/Staticfiles/src/Horse.StaticFiles.pas: -------------------------------------------------------------------------------- 1 | unit Horse.StaticFiles; 2 | 3 | interface 4 | 5 | uses 6 | 7 | System.Generics.Collections, 8 | System.Classes, 9 | System.SysUtils, 10 | Horse; 11 | 12 | type 13 | 14 | THorseStaticFileCallback = class 15 | private 16 | FPathRoot: string; 17 | FDefaultFiles: TArray; 18 | public 19 | class function New: THorseStaticFileCallback; 20 | function SetPathRoot(APathRoot: string): THorseStaticFileCallback; 21 | function SetDefaultFiles(ADefaultFiles: TArray): THorseStaticFileCallback; 22 | procedure Callback(AHorseRequest: THorseRequest; AHorseResponse: THorseResponse; ANext: TProc); 23 | end; 24 | 25 | THorseStaticFileManager = class 26 | private 27 | FCallbackList: TObjectList; 28 | class var FDefaultManager: THorseStaticFileManager; 29 | procedure SetCallbackList(const Value: TObjectList); 30 | protected 31 | class function GetDefaultManager: THorseStaticFileManager; static; 32 | public 33 | constructor Create; 34 | destructor Destroy; override; 35 | property CallbackList: TObjectList read FCallbackList write SetCallbackList; 36 | class destructor UnInitialize; 37 | class property DefaultManager: THorseStaticFileManager read GetDefaultManager; 38 | end; 39 | 40 | function HorseStaticFile(APathRoot: string; const ADefaultFiles: TArray = []): THorseCallback; overload; 41 | 42 | implementation 43 | 44 | uses 45 | System.IOUtils, 46 | System.Net.Mime; 47 | 48 | function HorseStaticFile(APathRoot: string; const ADefaultFiles: TArray = []): THorseCallback; overload; 49 | var 50 | LHorseStaticFileCallback: THorseStaticFileCallback; 51 | begin 52 | LHorseStaticFileCallback := THorseStaticFileCallback.Create; 53 | 54 | THorseStaticFileManager 55 | .DefaultManager 56 | .CallbackList 57 | .Add(LHorseStaticFileCallback); 58 | 59 | Result := 60 | LHorseStaticFileCallback 61 | .SetPathRoot(APathRoot) 62 | .SetDefaultFiles(ADefaultFiles) 63 | .Callback; 64 | end; 65 | 66 | { THorseStaticFileCallback } 67 | 68 | procedure THorseStaticFileCallback.Callback(AHorseRequest: THorseRequest; AHorseResponse: THorseResponse; ANext: TProc); 69 | var 70 | LFileStream: TFileStream; 71 | LNormalizeFileName: string; 72 | LType: string; 73 | LKind: TMimeTypes.TKind; 74 | I: Integer; 75 | begin 76 | 77 | LNormalizeFileName := AHorseRequest.RawWebRequest.RawPathInfo.TrimLeft(['/']); 78 | 79 | LNormalizeFileName := LNormalizeFileName.Replace('/', TPath.DirectorySeparatorChar); 80 | 81 | LNormalizeFileName := TPath.Combine(FPathRoot, LNormalizeFileName); 82 | 83 | if (TDirectory.Exists(LNormalizeFileName)) or (ExtractFileName(LNormalizeFileName).IsEmpty) then 84 | begin 85 | for I := Low(FDefaultFiles) to High(FDefaultFiles) do 86 | begin 87 | if TFile.Exists(TPath.Combine(LNormalizeFileName, FDefaultFiles[I])) then 88 | begin 89 | LNormalizeFileName := TPath.Combine(LNormalizeFileName, FDefaultFiles[I]); 90 | Break; 91 | end; 92 | end; 93 | end; 94 | 95 | if TFile.Exists(LNormalizeFileName) then 96 | begin 97 | LFileStream := TFileStream.Create(LNormalizeFileName, fmShareDenyNone or fmOpenRead); 98 | AHorseResponse.RawWebResponse.ContentStream := LFileStream; 99 | TMimeTypes.Default.GetFileInfo(LNormalizeFileName, LType, LKind); 100 | AHorseResponse.RawWebResponse.ContentType := LType; 101 | AHorseResponse.RawWebResponse.StatusCode := 200; 102 | AHorseResponse.RawWebResponse.SendResponse; 103 | raise EHorseCallbackInterrupted.Create; 104 | end; 105 | 106 | ANext(); 107 | end; 108 | 109 | class function THorseStaticFileCallback.New: THorseStaticFileCallback; 110 | begin 111 | Result := THorseStaticFileCallback.Create; 112 | end; 113 | 114 | function THorseStaticFileCallback.SetPathRoot(APathRoot: string): THorseStaticFileCallback; 115 | begin 116 | Result := Self; 117 | FPathRoot := APathRoot; 118 | end; 119 | 120 | function THorseStaticFileCallback.SetDefaultFiles(ADefaultFiles: TArray): THorseStaticFileCallback; 121 | begin 122 | Result := Self; 123 | FDefaultFiles := ADefaultFiles; 124 | end; 125 | 126 | { THorseStaticFileManager } 127 | 128 | constructor THorseStaticFileManager.Create; 129 | begin 130 | FCallbackList := TObjectList.Create(True); 131 | end; 132 | 133 | destructor THorseStaticFileManager.Destroy; 134 | begin 135 | FCallbackList.Free; 136 | inherited; 137 | end; 138 | 139 | class function THorseStaticFileManager.GetDefaultManager: THorseStaticFileManager; 140 | begin 141 | if FDefaultManager = nil then 142 | FDefaultManager := THorseStaticFileManager.Create; 143 | Result := FDefaultManager; 144 | end; 145 | 146 | procedure THorseStaticFileManager.SetCallbackList(const Value: TObjectList); 147 | begin 148 | FCallbackList := Value; 149 | end; 150 | 151 | class destructor THorseStaticFileManager.UnInitialize; 152 | begin 153 | FreeAndNil(FDefaultManager); 154 | end; 155 | 156 | end. 157 | -------------------------------------------------------------------------------- /Samples/ISAPI/ISAPI.dpr: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/ISAPI/ISAPI.dpr -------------------------------------------------------------------------------- /Samples/ISAPI/ISAPI.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/ISAPI/ISAPI.res -------------------------------------------------------------------------------- /Samples/ISAPI/Readme.txt: -------------------------------------------------------------------------------- 1 | Samples with Horse 2 | 3 | https://github.com/HashLoad/horse -------------------------------------------------------------------------------- /Samples/Postman/FastReportPrinter.postman_collection_v2.1.json: -------------------------------------------------------------------------------- 1 | { 2 | "info": { 3 | "_postman_id": "7f1185c0-f128-4aac-90c0-6c5c7c82d828", 4 | "name": "Fast Report Printer", 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/printer/43", 26 | "protocol": "http", 27 | "host": [ 28 | "localhost" 29 | ], 30 | "port": "9000", 31 | "path": [ 32 | "printer", 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/printer/43", 57 | "protocol": "http", 58 | "host": [ 59 | "localhost" 60 | ], 61 | "port": "9001", 62 | "path": [ 63 | "printer", 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/printer/43", 88 | "protocol": "http", 89 | "host": [ 90 | "localhost" 91 | ], 92 | "port": "9002", 93 | "path": [ 94 | "printer", 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/frxprinterisapi/ISAPI.dll/printer/43", 119 | "protocol": "http", 120 | "host": [ 121 | "localhost" 122 | ], 123 | "path": [ 124 | "frxprinterisapi", 125 | "ISAPI.dll", 126 | "printer", 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/frxprintercgi/cgi.exe/printer/43", 151 | "protocol": "http", 152 | "host": [ 153 | "localhost" 154 | ], 155 | "path": [ 156 | "frxprintercgi", 157 | "cgi.exe", 158 | "printer", 159 | "43" 160 | ] 161 | } 162 | }, 163 | "response": [] 164 | } 165 | ] 166 | } -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 ConnectDB(const pServer: string; const pDataBase: string; 29 | pFDConnection: TFDConnection; out poError: string): Boolean; 30 | class function QueryOpen(pQuery: TFDQuery; const pSQL: string; out poError: string): Boolean; static; 31 | end; 32 | 33 | implementation 34 | 35 | { TUtils } 36 | 37 | class function TUtils.ConnectDB(const pServer: string; const pDataBase: string; 38 | pFDConnection: TFDConnection; out poError: string): Boolean; 39 | var 40 | lFBConnectionDefParams: TFDPhysFBConnectionDefParams; // FIREBIRD CONNECTION PARAMS 41 | begin 42 | Result := False; 43 | 44 | lFBConnectionDefParams := TFDPhysFBConnectionDefParams(pFDConnection.Params); 45 | lFBConnectionDefParams.DriverID := 'FB'; 46 | lFBConnectionDefParams.Server := pServer; 47 | lFBConnectionDefParams.Database := pDataBase; 48 | lFBConnectionDefParams.UserName := 'SYSDBA'; 49 | lFBConnectionDefParams.Password := 'masterkey'; 50 | lFBConnectionDefParams.Protocol := TIBProtocol.ipLocal; 51 | 52 | pFDConnection.FetchOptions.Mode := TFDFetchMode.fmAll; //fmAll 53 | pFDConnection.ResourceOptions.AutoConnect := False; 54 | pFDConnection.ResourceOptions.SilentMode := True; 55 | 56 | try 57 | pFDConnection.Open; 58 | Result := True; 59 | except 60 | on E: Exception do 61 | poError := E.Message; 62 | end; 63 | end; 64 | 65 | class function TUtils.QueryOpen(pQuery: TFDQuery; 66 | const pSQL: string; out poError: string): Boolean; 67 | begin 68 | Result := False; 69 | try 70 | pQuery.Close; 71 | pQuery.SQL.Clear; 72 | pQuery.SQL.Add(pSQL); 73 | pQuery.Open; 74 | Result := True; 75 | except 76 | on E: Exception do 77 | poError := E.Message; 78 | end; 79 | end; 80 | 81 | class function TUtils.PathApp: string; 82 | begin 83 | Result := IncludeTrailingPathDelimiter(ExtractFilePath(PathAppFile)); 84 | end; 85 | 86 | class function TUtils.PathAppFileDB: string; 87 | var 88 | lPathApp: string; 89 | lPos: Integer; 90 | begin 91 | lPathApp := Self.PathApp; 92 | lPos := Pos('fastreportprinter', LowerCase(lPathApp)); 93 | lPathApp := IncludeTrailingPathDelimiter(Copy(lPathApp, 1, (lPos + Length('FastReportPrinter')))); 94 | Result := lPathApp + 'Samples\DB\FAST_REPORT_PRINTER.FDB'; 95 | end; 96 | 97 | class function TUtils.PathAppFileReport: string; 98 | var 99 | lPathApp: string; 100 | lPos: Integer; 101 | begin 102 | lPathApp := Self.PathApp; 103 | lPos := Pos('fastreportprinter', LowerCase(lPathApp)); 104 | lPathApp := IncludeTrailingPathDelimiter(Copy(lPathApp, 1, (lPos + Length('FastReportPrinter')))); 105 | Result := lPathApp + 'Samples\Report\rptLocalidadesIBGE.fr3'; 106 | end; 107 | 108 | class function TUtils.PathAppFile: string; 109 | var 110 | lFileName: array[0..MAX_PATH] of Char; 111 | lReturn: Cardinal; 112 | begin 113 | 114 | //DELPHI PACKAGE 115 | if ModuleIsPackage then begin 116 | Result := ParamStr(0); 117 | end 118 | else //EXE/DLL 119 | begin 120 | FillChar(lFileName, SizeOf(lFileName), #0); 121 | lReturn := GetModuleFileName(HInstance, lFileName, MAX_PATH); 122 | 123 | if (lReturn > 0) then 124 | Result := string(lFileName) 125 | else 126 | raise Exception.Create(SysErrorMessage(GetLastError)); 127 | end; 128 | 129 | //IIS 130 | if Result.StartsWith('\\?\') then 131 | Delete(Result, 1, 4); 132 | end; 133 | 134 | end. 135 | -------------------------------------------------------------------------------- /Samples/VCL/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/VCL/Main.pas -------------------------------------------------------------------------------- /Samples/VCL/Samples.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/VCL/Samples.res -------------------------------------------------------------------------------- /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/VCL/VCL.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/VCL/VCL.res -------------------------------------------------------------------------------- /Samples/VCLHorse/Main.dfm: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | Caption = 'Impress'#227'o Fast Report' 5 | ClientHeight = 126 6 | ClientWidth = 284 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 lblPort: 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 = 'Imprimir' 59 | Enabled = False 60 | TabOrder = 3 61 | OnClick = btnBrowserClick 62 | end 63 | end 64 | -------------------------------------------------------------------------------- /Samples/VCLHorse/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/VCLHorse/Main.pas -------------------------------------------------------------------------------- /Samples/VCLHorse/Readme.txt: -------------------------------------------------------------------------------- 1 | Samples with Horse 2 | 3 | https://github.com/HashLoad/horse -------------------------------------------------------------------------------- /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/VCLHorse/VCLHorse.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/VCLHorse/VCLHorse.res -------------------------------------------------------------------------------- /Samples/WindowsService/Main.dfm: -------------------------------------------------------------------------------- 1 | object srvFastReportPrint: TsrvFastReportPrint 2 | OldCreateOrder = False 3 | DisplayName = 'Windows Server - Fast Report :: Print' 4 | OnStart = ServiceStart 5 | Height = 150 6 | Width = 215 7 | end 8 | -------------------------------------------------------------------------------- /Samples/WindowsService/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/WindowsService/Main.pas -------------------------------------------------------------------------------- /Samples/WindowsService/WindowsServer.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/WindowsService/WindowsServer.res -------------------------------------------------------------------------------- /Samples/WindowsService/WindowsService.dpr: -------------------------------------------------------------------------------- 1 | program WindowsService; 2 | 3 | uses 4 | Vcl.SvcMgr, 5 | Main in 'Main.pas' {srvFastReportPrint: 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(TsrvFastReportPrint, srvFastReportPrint); 29 | Application.Run; 30 | end. 31 | -------------------------------------------------------------------------------- /Samples/WindowsService/WindowsService.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/WindowsService/WindowsService.res -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/Main.dfm: -------------------------------------------------------------------------------- 1 | object srvFastReportPrintHorse: TsrvFastReportPrintHorse 2 | OldCreateOrder = False 3 | DisplayName = 'Windows Server - Fast Report(Print) :: Horse' 4 | OnStart = ServiceStart 5 | Height = 150 6 | Width = 215 7 | end 8 | -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/Main.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/WindowsServiceHorse/Main.pas -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/Readme.txt: -------------------------------------------------------------------------------- 1 | Samples with Horse 2 | 3 | https://github.com/HashLoad/horse -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/WindowsServiceHorse.dpr: -------------------------------------------------------------------------------- 1 | program WindowsServiceHorse; 2 | 3 | uses 4 | Vcl.SvcMgr, 5 | Main in 'Main.pas' {srvFastReportPrintHorse: 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(TsrvFastReportPrintHorse, srvFastReportPrintHorse); 29 | Application.Run; 30 | end. 31 | -------------------------------------------------------------------------------- /Samples/WindowsServiceHorse/WindowsServiceHorse.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Samples/WindowsServiceHorse/WindowsServiceHorse.res -------------------------------------------------------------------------------- /Source/FRPrinter.Core.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/antoniojmsjr/FastReportPrinter/fabe30dfd6f3881d4e814ecc9e299b1ccb2cff43/Source/FRPrinter.Core.pas -------------------------------------------------------------------------------- /Source/FRPrinter.Interfaces.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | { } 3 | { FRPrinter.Interfaces } 4 | { } 5 | { Copyright (C) Antônio José Medeiros Schneider Júnior } 6 | { } 7 | { https://github.com/antoniojmsjr/FastReportPrinter } 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 FRPrinter.Interfaces; 26 | 27 | interface 28 | 29 | uses 30 | System.Classes, Data.DB, frxClass, frxDBSet, FRPrinter.Types; 31 | 32 | type 33 | IFRPrinterExecute = interface; 34 | IFRPrinterDataSets = interface; 35 | 36 | IFRPrinter = interface 37 | ['{7DAE128C-3F08-447C-888A-8D5F5BBF1DDA}'] 38 | function GetFRPrintertDataSets: IFRPrinterDataSets; 39 | function GetFRPrinterExecute: IFRPrinterExecute; 40 | 41 | property DataSets: IFRPrinterDataSets read GetFRPrintertDataSets; 42 | property Print: IFRPrinterExecute read GetFRPrinterExecute; 43 | end; 44 | 45 | IFRPrinterDataSets = interface 46 | ['{352279D1-95C5-41B7-82E0-EBBB2E09890D}'] 47 | function GetEnd: IFRPrinter; 48 | function SetDataSet(DataSet: TDataSet; const UserName: string): IFRPrinterDataSets; overload; 49 | function SetDataSet(DataSet: TfrxDBDataset): IFRPrinterDataSets; overload; 50 | 51 | property &End: IFRPrinter read GetEnd; 52 | end; 53 | 54 | IFRPrinterExecute = interface 55 | ['{639633AE-9972-4589-86D6-0EF515BCD344}'] 56 | function SetExceptionFastReport(const Value: Boolean): IFRPrinterExecute; 57 | function SetPrinter(const PrinterName: string): IFRPrinterExecute; 58 | function SetFileReport(const FileName: string): IFRPrinterExecute; overload; 59 | function SetFileReport(FileStream: TStream): IFRPrinterExecute; overload; 60 | function Report(const CallbackReport: TFRPrinterReportCallback): IFRPrinterExecute; 61 | function Execute: Boolean; 62 | end; 63 | 64 | implementation 65 | 66 | end. 67 | -------------------------------------------------------------------------------- /Source/FRPrinter.Types.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | { } 3 | { FRPrinter.Types } 4 | { } 5 | { Copyright (C) Antônio José Medeiros Schneider Júnior } 6 | { } 7 | { https://github.com/antoniojmsjr/FastReportPrinter } 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 FRPrinter.Types; 26 | 27 | interface 28 | 29 | uses 30 | frxClass, System.Classes, System.SysUtils; 31 | 32 | type 33 | TFRPrinterReportCallback = reference to procedure(frxReport: TfrxReport); 34 | 35 | EFRPrinter = class(Exception) 36 | private 37 | { private declarations } 38 | protected 39 | { protected declarations } 40 | FMessage: string; 41 | public 42 | { public declarations } 43 | end; 44 | 45 | EFRPrinterFileReport = class(EFRPrinter) 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 | EFRPrinterPrint = class(EFRPrinter) 59 | private 60 | { private declarations } 61 | FPrinterName: string; 62 | protected 63 | { protected declarations } 64 | public 65 | { public declarations } 66 | constructor Create(const pPrinterName: string; const pMessage: string); 67 | function ToString: string; override; 68 | property PrinterName: string read FPrinterName; 69 | end; 70 | 71 | EFRPrinterPrepareReport = class(EFRPrinter) 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 'EFRPrinterPrint'} 88 | constructor EFRPrinterPrint.Create(const pPrinterName: string; 89 | const pMessage: string); 90 | begin 91 | inherited Create('See ToString.'); 92 | FPrinterName := pPrinterName; 93 | FMessage := pMessage; 94 | end; 95 | 96 | function EFRPrinterPrint.ToString: string; 97 | begin 98 | Result := EmptyStr; 99 | Result := Concat(Result, 'Printer Print', sLineBreak, sLineBreak); 100 | Result := Concat(Result, 'Printer Name: ', FPrinterName, sLineBreak); 101 | Result := Concat(Result, 'Message: ', FMessage); 102 | end; 103 | {$ENDREGION} 104 | 105 | {$REGION 'EFRPrinterPrepareReport'} 106 | constructor EFRPrinterPrepareReport.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 EFRPrinterPrepareReport.Destroy; 115 | begin 116 | FMessages.Free; 117 | inherited Destroy; 118 | end; 119 | 120 | function EFRPrinterPrepareReport.ToString: string; 121 | var 122 | I: Integer; 123 | begin 124 | Result := EmptyStr; 125 | Result := Concat(Result, 'Printer 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 'EFRPrinterFileReport'} 132 | constructor EFRPrinterFileReport.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 EFRPrinterFileReport.ToString: string; 141 | begin 142 | Result := EmptyStr; 143 | Result := Concat(Result, 'Printer File', sLineBreak, sLineBreak); 144 | Result := Concat(Result, 'File: ', FFileName, sLineBreak); 145 | Result := Concat(Result, 'Message: ', FMessage); 146 | end; 147 | {$ENDREGION} 148 | 149 | end. 150 | -------------------------------------------------------------------------------- /Source/FRPrinter.pas: -------------------------------------------------------------------------------- 1 | {******************************************************************************} 2 | { } 3 | { FRPrinter } 4 | { } 5 | { Copyright (C) Antônio José Medeiros Schneider Júnior } 6 | { } 7 | { https://github.com/antoniojmsjr/FastReportPrinter } 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 FRPrinter; 26 | 27 | interface 28 | 29 | uses 30 | FRPrinter.Interfaces, FRPrinter.Core; 31 | 32 | type 33 | 34 | TFRPrinter = class(TFRPrinterCustom) 35 | private 36 | { private declarations } 37 | protected 38 | { protected declarations } 39 | public 40 | { public declarations } 41 | class function New: IFRPrinter; 42 | end; 43 | 44 | implementation 45 | 46 | { TFRPrinter } 47 | 48 | class function TFRPrinter.New: IFRPrinter; 49 | begin 50 | Result := Self.Create; 51 | end; 52 | 53 | end. 54 | -------------------------------------------------------------------------------- /boss-lock.json: -------------------------------------------------------------------------------- 1 | { 2 | "hash": "d41d8cd98f00b204e9800998ecf8427e", 3 | "updated": "2022-08-02T17:12:16.4426403-03:00", 4 | "installedModules": {} 5 | } -------------------------------------------------------------------------------- /boss.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "FastReportPrinter", 3 | "description": "Biblioteca de impressão de relatórios com Fast Report para ambientes multithreading e não GUI(Graphical User Interface).", 4 | "version": "1.0.0", 5 | "homepage": "\u0016https://github.com/antoniojmsjr/FastReportPrinter", 6 | "mainsrc": "Source", 7 | "projects": [], 8 | "dependencies": {} 9 | } --------------------------------------------------------------------------------