From 72d4d1f1cd35a59644b732419f28305f0798e5ab Mon Sep 17 00:00:00 2001 From: DomenicoMammola Date: Wed, 25 Jun 2025 14:16:38 +0200 Subject: [PATCH] Source code for the two tutorials ("The Brook framework", "A CRUD server with the Brook framework") to be added to the wiki --- Examples/LCL/Tutorial1/source/TestProject.lpi | 70 ++++++ Examples/LCL/Tutorial1/source/TestProject.lpr | 69 ++++++ Examples/LCL/Tutorial1/source/httpserver.pas | 57 +++++ Examples/LCL/Tutorial1/source/routeping.pas | 40 ++++ .../Tutorial1/source_https/TestProject.lpi | 70 ++++++ .../Tutorial1/source_https/TestProject.lpr | 69 ++++++ .../LCL/Tutorial1/source_https/httpserver.pas | 70 ++++++ .../LCL/Tutorial1/source_https/routeping.pas | 40 ++++ Examples/LCL/Tutorial2/TestProject.lpi | 78 +++++++ Examples/LCL/Tutorial2/TestProject.lpr | 68 ++++++ Examples/LCL/Tutorial2/alienpets.pas | 215 ++++++++++++++++++ Examples/LCL/Tutorial2/httpserver.pas | 74 ++++++ Examples/LCL/Tutorial2/modulealienpets.pas | 212 +++++++++++++++++ Examples/LCL/Tutorial2/standardheaders.pas | 82 +++++++ Examples/LCL/Tutorial2/standardresponses.pas | 32 +++ 15 files changed, 1246 insertions(+) create mode 100644 Examples/LCL/Tutorial1/source/TestProject.lpi create mode 100644 Examples/LCL/Tutorial1/source/TestProject.lpr create mode 100644 Examples/LCL/Tutorial1/source/httpserver.pas create mode 100644 Examples/LCL/Tutorial1/source/routeping.pas create mode 100644 Examples/LCL/Tutorial1/source_https/TestProject.lpi create mode 100644 Examples/LCL/Tutorial1/source_https/TestProject.lpr create mode 100644 Examples/LCL/Tutorial1/source_https/httpserver.pas create mode 100644 Examples/LCL/Tutorial1/source_https/routeping.pas create mode 100644 Examples/LCL/Tutorial2/TestProject.lpi create mode 100644 Examples/LCL/Tutorial2/TestProject.lpr create mode 100644 Examples/LCL/Tutorial2/alienpets.pas create mode 100644 Examples/LCL/Tutorial2/httpserver.pas create mode 100644 Examples/LCL/Tutorial2/modulealienpets.pas create mode 100644 Examples/LCL/Tutorial2/standardheaders.pas create mode 100644 Examples/LCL/Tutorial2/standardresponses.pas diff --git a/Examples/LCL/Tutorial1/source/TestProject.lpi b/Examples/LCL/Tutorial1/source/TestProject.lpi new file mode 100644 index 0000000..f3d3dfb --- /dev/null +++ b/Examples/LCL/Tutorial1/source/TestProject.lpi @@ -0,0 +1,70 @@ + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes> + <Item Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + </RunParams> + <Units> + <Unit> + <Filename Value="TestProject.lpr"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="httpserver.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="routeping.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="TestProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="../../../../Source"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf3"/> + </Debugging> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions> + <Item> + <Name Value="EAbort"/> + </Item> + <Item> + <Name Value="ECodetoolError"/> + </Item> + <Item> + <Name Value="EFOpenError"/> + </Item> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Examples/LCL/Tutorial1/source/TestProject.lpr b/Examples/LCL/Tutorial1/source/TestProject.lpr new file mode 100644 index 0000000..0582869 --- /dev/null +++ b/Examples/LCL/Tutorial1/source/TestProject.lpr @@ -0,0 +1,69 @@ +program TestProject; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX} + cthreads, + {$ENDIF} + Classes, SysUtils, CustApp, httpserver, routeping + { you can add units after this }; + +type + + { TBrookframeworkTest } + + TBrookframeworkTest = class(TCustomApplication) + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + end; + +{ TBrookframeworkTest } + +procedure TBrookframeworkTest.DoRun; +var + server: THTTPServer; +begin + server := THTTPServer.Create(nil); + try + server.SetupServer; + server.Open; + if not server.Active then + begin + WriteLn('Unable to start server at http://localhost:', server.Port); + Terminate(-1); + end + else + begin + WriteLn('Server running at http://localhost:', server.Port); + ReadLn; + end; + finally + server.Free; + end; + Terminate; +end; + +constructor TBrookframeworkTest.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +destructor TBrookframeworkTest.Destroy; +begin + inherited Destroy; +end; + +var + Application: TBrookframeworkTest; +begin + Application:=TBrookframeworkTest.Create(nil); + Application.Title:='Brookframework Test Server'; + Application.Run; + Application.Free; +end. + diff --git a/Examples/LCL/Tutorial1/source/httpserver.pas b/Examples/LCL/Tutorial1/source/httpserver.pas new file mode 100644 index 0000000..0a95501 --- /dev/null +++ b/Examples/LCL/Tutorial1/source/httpserver.pas @@ -0,0 +1,57 @@ +unit httpserver; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, + BrookHTTPServer, BrookHTTPRequest, + BrookHTTPResponse, BrookURLRouter, BrookUtility; + +type + + { THTTPServer } + + THTTPServer = class(TBrookHTTPServer) + private + FRouter : TBrookURLRouter; + protected + procedure DoRequest(ASender: TObject; ARequest: TBrookHTTPRequest; + AResponse: TBrookHTTPResponse); override; + public + constructor Create(AOwner: TComponent); override; + + procedure SetupServer; + end; + + +implementation + +uses + routeping; + +{ THTTPServer } + +procedure THTTPServer.DoRequest(ASender: TObject; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + FRouter.Route(ASender, ARequest, AResponse); +end; + +constructor THTTPServer.Create(AOwner: TComponent); +var + rp : TRoutePing; +begin + inherited Create(AOwner); + FRouter := TBrookURLRouter.Create(Self); + rp := TRoutePing.Create(FRouter.Routes); + FRouter.Active := true; +end; + +procedure THTTPServer.SetupServer; +begin + Self.Port := 8080; +end; + +end. + diff --git a/Examples/LCL/Tutorial1/source/routeping.pas b/Examples/LCL/Tutorial1/source/routeping.pas new file mode 100644 index 0000000..7938b68 --- /dev/null +++ b/Examples/LCL/Tutorial1/source/routeping.pas @@ -0,0 +1,40 @@ +unit routeping; + +{$mode ObjFPC}{$H+} + +interface + +uses + BrookUtility, + BrookHTTPRequest, + BrookHTTPResponse, + BrookURLRouter; + +type + + { TRoutePing } + + TRoutePing = class(TBrookURLRoute) + protected + procedure DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); override; + public + procedure AfterConstruction; override; + end; + +implementation + +{ TRoutePing } + +procedure TRoutePing.DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + AResponse.Send('<html><head><title>PingPong', 'text/html; charset=utf-8', 200); +end; + +procedure TRoutePing.AfterConstruction; +begin + Methods:= [rmGET]; + Pattern:= '/ping'; +end; + +end. + diff --git a/Examples/LCL/Tutorial1/source_https/TestProject.lpi b/Examples/LCL/Tutorial1/source_https/TestProject.lpi new file mode 100644 index 0000000..f3d3dfb --- /dev/null +++ b/Examples/LCL/Tutorial1/source_https/TestProject.lpi @@ -0,0 +1,70 @@ + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes> + <Item Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + </RunParams> + <Units> + <Unit> + <Filename Value="TestProject.lpr"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="httpserver.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="routeping.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="TestProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="../../../../Source"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf3"/> + </Debugging> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions> + <Item> + <Name Value="EAbort"/> + </Item> + <Item> + <Name Value="ECodetoolError"/> + </Item> + <Item> + <Name Value="EFOpenError"/> + </Item> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Examples/LCL/Tutorial1/source_https/TestProject.lpr b/Examples/LCL/Tutorial1/source_https/TestProject.lpr new file mode 100644 index 0000000..a9b5c39 --- /dev/null +++ b/Examples/LCL/Tutorial1/source_https/TestProject.lpr @@ -0,0 +1,69 @@ +program TestProject; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX} + cthreads, + {$ENDIF} + Classes, SysUtils, CustApp, httpserver, routeping + { you can add units after this }; + +type + + { TBrookframeworkTest } + + TBrookframeworkTest = class(TCustomApplication) + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + end; + +{ TBrookframeworkTest } + +procedure TBrookframeworkTest.DoRun; +var + server: THTTPServer; +begin + server := THTTPServer.Create(nil); + try + server.SetupServer; + server.Open; + if not server.Active then + begin + WriteLn('Unable to start server at https://localhost:', server.Port); + Terminate(-1); + end + else + begin + WriteLn('Server running at https://localhost:', server.Port); + ReadLn; + end; + finally + server.Free; + end; + Terminate; +end; + +constructor TBrookframeworkTest.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +destructor TBrookframeworkTest.Destroy; +begin + inherited Destroy; +end; + +var + Application: TBrookframeworkTest; +begin + Application:=TBrookframeworkTest.Create(nil); + Application.Title:='Brookframework Test Server'; + Application.Run; + Application.Free; +end. + diff --git a/Examples/LCL/Tutorial1/source_https/httpserver.pas b/Examples/LCL/Tutorial1/source_https/httpserver.pas new file mode 100644 index 0000000..c4d14ac --- /dev/null +++ b/Examples/LCL/Tutorial1/source_https/httpserver.pas @@ -0,0 +1,70 @@ +unit httpserver; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, + BrookHTTPServer, BrookHTTPRequest, + BrookHTTPResponse, BrookURLRouter, BrookUtility; + +type + + { THTTPServer } + + THTTPServer = class(TBrookHTTPServer) + private + FRouter : TBrookURLRouter; + protected + procedure DoRequest(ASender: TObject; ARequest: TBrookHTTPRequest; + AResponse: TBrookHTTPResponse); override; + public + constructor Create(AOwner: TComponent); override; + + procedure SetupServer; + end; + + +implementation + +uses + routeping; + +{ THTTPServer } + +procedure THTTPServer.DoRequest(ASender: TObject; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + FRouter.Route(ASender, ARequest, AResponse); +end; + +constructor THTTPServer.Create(AOwner: TComponent); +var + rp : TRoutePing; +begin + inherited Create(AOwner); + FRouter := TBrookURLRouter.Create(Self); + rp := TRoutePing.Create(FRouter.Routes); + FRouter.Active := true; +end; + +procedure THTTPServer.SetupServer; +var + lst : TStringList; +begin + Self.Port := 443; + + lst := TStringList.Create; + try + lst.LoadFromFile('self_signed.pem'); + Self.Security.Certificate:= lst.Text; + lst.LoadFromFile('self_signed_key.pem'); + Self.Security.PrivateKey:= lst.Text; + Self.Security.Active:= true; + finally + lst.Free; + end; +end; + +end. + diff --git a/Examples/LCL/Tutorial1/source_https/routeping.pas b/Examples/LCL/Tutorial1/source_https/routeping.pas new file mode 100644 index 0000000..7938b68 --- /dev/null +++ b/Examples/LCL/Tutorial1/source_https/routeping.pas @@ -0,0 +1,40 @@ +unit routeping; + +{$mode ObjFPC}{$H+} + +interface + +uses + BrookUtility, + BrookHTTPRequest, + BrookHTTPResponse, + BrookURLRouter; + +type + + { TRoutePing } + + TRoutePing = class(TBrookURLRoute) + protected + procedure DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); override; + public + procedure AfterConstruction; override; + end; + +implementation + +{ TRoutePing } + +procedure TRoutePing.DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + AResponse.Send('<html><head><title>PingPong', 'text/html; charset=utf-8', 200); +end; + +procedure TRoutePing.AfterConstruction; +begin + Methods:= [rmGET]; + Pattern:= '/ping'; +end; + +end. + diff --git a/Examples/LCL/Tutorial2/TestProject.lpi b/Examples/LCL/Tutorial2/TestProject.lpi new file mode 100644 index 0000000..b1c381e --- /dev/null +++ b/Examples/LCL/Tutorial2/TestProject.lpi @@ -0,0 +1,78 @@ + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes> + <Item Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <UseFileFilters Value="True"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + </RunParams> + <Units> + <Unit> + <Filename Value="TestProject.lpr"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="httpserver.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="modulealienpets.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="standardheaders.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + <Unit> + <Filename Value="standardresponses.pas"/> + <IsPartOfProject Value="True"/> + </Unit> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="TestProject"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="../../../Source"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Debugging> + <DebugInfoType Value="dsDwarf3"/> + </Debugging> + </Linking> + </CompilerOptions> + <Debugging> + <Exceptions> + <Item> + <Name Value="EAbort"/> + </Item> + <Item> + <Name Value="ECodetoolError"/> + </Item> + <Item> + <Name Value="EFOpenError"/> + </Item> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/Examples/LCL/Tutorial2/TestProject.lpr b/Examples/LCL/Tutorial2/TestProject.lpr new file mode 100644 index 0000000..b52746e --- /dev/null +++ b/Examples/LCL/Tutorial2/TestProject.lpr @@ -0,0 +1,68 @@ +program TestProject; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX} + cthreads, + {$ENDIF} + Classes, SysUtils, CustApp, httpserver, standardheaders, standardresponses; + +type + + { TBrookframeworkTest } + + TBrookframeworkTest = class(TCustomApplication) + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + end; + +{ TBrookframeworkTest } + +procedure TBrookframeworkTest.DoRun; +var + server: THTTPServer; +begin + server := THTTPServer.Create(nil); + try + server.SetupServer; + server.Open; + if not server.Active then + begin + WriteLn('Unable to start server at https://localhost:', server.Port); + Terminate(-1); + end + else + begin + WriteLn('Server running at https://localhost:', server.Port); + ReadLn; + end; + finally + server.Free; + end; + Terminate; +end; + +constructor TBrookframeworkTest.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +destructor TBrookframeworkTest.Destroy; +begin + inherited Destroy; +end; + +var + Application: TBrookframeworkTest; +begin + Application:=TBrookframeworkTest.Create(nil); + Application.Title:='Brookframework Test Server'; + Application.Run; + Application.Free; +end. + diff --git a/Examples/LCL/Tutorial2/alienpets.pas b/Examples/LCL/Tutorial2/alienpets.pas new file mode 100644 index 0000000..26b009e --- /dev/null +++ b/Examples/LCL/Tutorial2/alienpets.pas @@ -0,0 +1,215 @@ +unit alienpets; + +{$mode ObjFPC}{$H+} + +interface + +uses + Contnrs, fpjson, syncobjs; + +type + + { TAlienPet } + TAlienPet = class + strict private + FId : integer; + FName : string; + FSpecies : string; + public + constructor Create; + procedure Clear; + procedure Assign(const aSource : TAlienPet); + procedure FromJson (aJsonData : TJSONData); overload; + procedure FromJson (const aJsonString : string); overload; + function ToJson: String; + + property Id : integer read FId write FId; + property Name : string read FName write FName; + property Species : string read FSpecies write FSpecies; + end; + + { TAlienPetsArchive } + + TAlienPetsArchive = class + strict private + FList : TObjectList; + FCriticalSection : TCriticalSection; + FLastId : integer; + function Get(const aIndex : integer): TAlienPet; + public + constructor Create; + destructor Destroy; override; + function ToJson: String; // convert the archive to a json string + + procedure Add(const aAlienPet : TAlienPet); // add a pet to the archive + procedure Delete (const aId : integer); // delete a pet from the archive by its own id + procedure Update(const aSourceAlienPet : TAlienPet); // update a pet in the archive + function GetNewId : integer; // generate a new unique id (for a newly created pet) + end; + + +implementation + +uses + SysUtils, Math; + +{ TAlienPet } + +procedure TAlienPet.FromJson(aJsonData : TJSONData); +var + tmp : TJSONData; +begin + Clear; + tmp := aJsonData.FindPath('id'); + if Assigned(tmp) then + Self.FId := tmp.Value; + tmp := aJsonData.FindPath('name'); + if Assigned(tmp) then + Self.FName := tmp.Value; + tmp := aJsonData.FindPath('species'); + if Assigned(tmp) then + Self.FSpecies := tmp.Value; +end; + +procedure TAlienPet.FromJson(const aJsonString: string); +var + jData, subdata : TJSONData; +begin + jData := GetJSON(aJsonString); + try + subData := jData.FindPath('alienpet'); + if Assigned(subData) then + fromJson(subData) + else + Clear; + finally + jData.Free; + end; +end; + +function TAlienPet.ToJson: String; +begin + Result := '{"id":' + IntToStr(Id) + ', "name":"' + FName + '", "species":"' + FSpecies + '"}'; +end; + +procedure TAlienPet.Clear; +begin + FId := 0; + FName := ''; + FSpecies := ''; +end; + +procedure TAlienPet.Assign(const aSource: TAlienPet); +begin + FId := aSource.Id; + FName := aSource.Name; + FSpecies := aSource.Species; +end; + +constructor TAlienPet.Create; +begin + Clear; +end; + +{ TAlienPetsArchive } + +constructor TAlienPetsArchive.Create; +begin + FList := TObjectList.Create(true); + FCriticalSection := TCriticalSection.Create; + FLastId := 0; +end; + +destructor TAlienPetsArchive.Destroy; +begin + FCriticalSection.Free; + FList.Free; + inherited Destroy; +end; + +function TAlienPetsArchive.ToJson: String; +var + i : integer; + sep : String; +begin + sep := ''; + Result := '['; + FCriticalSection.Acquire; + try + for i := 0 to FList.Count - 1 do + begin + Result := Result + sep + Get(i).ToJson; + sep := ','; + end; + finally + FCriticalSection.Leave; + end; + Result := Result + ']'; +end; + +procedure TAlienPetsArchive.Add(const aAlienPet: TAlienPet); +begin + FCriticalSection.Acquire; + try + FList.Add(aAlienPet); + FLastId:= Max(aAlienPet.Id, FLastId); + finally + FCriticalSection.Leave; + end; +end; + +function TAlienPetsArchive.Get(const aIndex: integer): TAlienPet; +begin + Result := FList.Items[aIndex] as TAlienPet; +end; + +procedure TAlienPetsArchive.Delete(const aId: integer); +var + i : integer; +begin + FCriticalSection.Acquire; + try + for i := 0 to FList.Count - 1 do + begin + if Get(i).Id = aId then + begin + FList.Delete(i); + exit; + end; + end; + finally + FCriticalSection.Leave; + end; +end; + +procedure TAlienPetsArchive.Update(const aSourceAlienPet: TAlienPet); +var + i : integer; +begin + FCriticalSection.Acquire; + try + for i := 0 to FList.Count - 1 do + begin + if Get(i).Id = aSourceAlienPet.Id then + begin + Get(i).Assign(aSourceAlienPet); + exit; + end; + end; + finally + FCriticalSection.Leave; + end; +end; + +function TAlienPetsArchive.GetNewId: integer; +begin + FCriticalSection.Acquire; + try + inc(FLastId); + Result := FLastId; + finally + FCriticalSection.Leave; + end; +end; + +end. diff --git a/Examples/LCL/Tutorial2/httpserver.pas b/Examples/LCL/Tutorial2/httpserver.pas new file mode 100644 index 0000000..6127cf9 --- /dev/null +++ b/Examples/LCL/Tutorial2/httpserver.pas @@ -0,0 +1,74 @@ +unit httpserver; + +{$mode ObjFPC}{$H+} + +interface + +uses + Classes, SysUtils, + BrookHTTPServer, BrookHTTPRequest, + BrookHTTPResponse, BrookURLRouter, BrookUtility; + +type + + { THTTPServer } + + THTTPServer = class(TBrookHTTPServer) + private + FRouter : TBrookURLRouter; + protected + procedure DoRequest(ASender: TObject; ARequest: TBrookHTTPRequest; + AResponse: TBrookHTTPResponse); override; + public + constructor Create(AOwner: TComponent); override; + + procedure SetupServer; + end; + + +implementation + +uses + modulealienpets; + +{ THTTPServer } + +procedure THTTPServer.DoRequest(ASender: TObject; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + FRouter.Route(ASender, ARequest, AResponse); +end; + +constructor THTTPServer.Create(AOwner: TComponent); +var + speciesRoute : TRouteSpecies; + petsRoute : TRoutePetAliens; + petRoute : TRoutePetAlien; +begin + inherited Create(AOwner); + FRouter := TBrookURLRouter.Create(Self); + speciesRoute := TRouteSpecies.Create(FRouter.Routes); + petsRoute := TRoutePetAliens.Create(FRouter.Routes); + petRoute := TRoutePetAlien.Create(FRouter.Routes); + FRouter.Active := true; +end; + +procedure THTTPServer.SetupServer; +var + lst : TStringList; +begin + Self.Port := 443; + + lst := TStringList.Create; + try + lst.LoadFromFile('self_signed.pem'); + Self.Security.Certificate:= lst.Text; + lst.LoadFromFile('self_signed_key.pem'); + Self.Security.PrivateKey:= lst.Text; + Self.Security.Active:= true; + finally + lst.Free; + end; +end; + +end. + diff --git a/Examples/LCL/Tutorial2/modulealienpets.pas b/Examples/LCL/Tutorial2/modulealienpets.pas new file mode 100644 index 0000000..aa6c517 --- /dev/null +++ b/Examples/LCL/Tutorial2/modulealienpets.pas @@ -0,0 +1,212 @@ +unit modulealienpets; + +{$mode ObjFPC}{$H+} +interface + +uses + BrookUtility, + BrookHTTPRequest, + BrookHTTPResponse, + BrookURLRouter; + + +type + + { TRouteSpecies } + + TRouteSpecies = class(TBrookURLRoute) + protected + procedure DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); override; + public + procedure AfterConstruction; override; + end; + + { TRoutePetAliens } + + TRoutePetAliens = class(TBrookURLRoute) + protected + procedure DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); override; + public + procedure AfterConstruction; override; + end; + + TRoutePetAlien = class(TBrookURLRoute) + strict private + procedure Post(ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); + procedure Put(ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); + procedure Delete(const aPetId: integer; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); + protected + procedure DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); override; + public + procedure AfterConstruction; override; + end; + + +implementation +uses + fpjson, jsonparser, SysUtils, + standardheaders, standardresponses, alienpets; + +var + pets : TAlienPetsArchive; + +procedure InitAlienPetsArchive; +var + tmp : TAlienPet; +begin + tmp := TAlienPet.Create; + tmp.Id:= 1; + tmp.Name:= 'Prootelon'; + tmp.Species:= 'Zog'; + pets.Add(tmp); + + tmp := TAlienPet.Create; + tmp.Id:= 2; + tmp.Name:= 'Bidibop'; + tmp.Species:= 'Bloop'; + pets.Add(tmp); + + tmp := TAlienPet.Create; + tmp.Id:= 3; + tmp.Name:= 'Sguish'; + tmp.Species:= 'Gleep'; + pets.Add(tmp); +end; + + +{ TRouteSpecies } + +procedure TRouteSpecies.DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + if HandleOptions(ARoute, ARequest, AResponse) then + exit; + AddStandardHeaders(aResponse); + AResponse.Send('["Zog", "Gleep", "Bloop"]', 'application/json; charset=utf-8', 200); +end; + +procedure TRouteSpecies.AfterConstruction; +begin + Methods:= [rmGET, rmOPTIONS]; + Pattern:= '/species'; +end; + +procedure ReadAlienFromJson(const aData : TJSONData; alien : TAlienPet); +var + tmp : TJSONData; +begin + alien.Clear; + tmp := aData.FindPath('id'); + if Assigned(tmp) then + alien.Id := tmp.Value; + tmp := aData.FindPath('name'); + if Assigned(tmp) then + alien.Name := tmp.Value; + tmp := aData.FindPath('species'); + if Assigned(tmp) then + alien.Species := tmp.Value; +end; + +{ TRoutePetAliens } + +procedure TRoutePetAliens.DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + if HandleOptions(ARoute, ARequest, AResponse) then + exit; + AddStandardHeaders(AResponse); + AResponse.Send('{"pets":' + pets.ToJson + '}', 'application/json', 200); +end; + +procedure TRoutePetAliens.AfterConstruction; +begin + Methods:= [rmGET, rmOPTIONS]; + Pattern:= '/alienpets'; +end; + +procedure TRoutePetAlien.Post(ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +var + jData : TJSONData; + newAlien : TAlienPet; +begin + if ARequest.Payload.Text <> '' then + begin + jData := GetJSON(ARequest.Payload.Text); + try + newAlien := TAlienPet.Create; + ReadAlienFromJson(jData, newAlien); + newAlien.Id:= pets.GetNewId; + pets.Add(newAlien); + finally + jData.Free; + end; + AResponse.Send(newAlien.ToJson, 'application/json', 200); + end + else + AResponse.Send('Invalid request', 'text/plain', 400); +end; + +procedure TRoutePetAlien.Put(ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +var + jData : TJSONData; + editAlien : TAlienPet; +begin + if ARequest.Payload.Text <> '' then + begin + jData := GetJSON(ARequest.Payload.Text); + try + editAlien := TAlienPet.Create; + try + ReadAlienFromJson(jData, editAlien); + pets.Update(editAlien); + AResponse.Send(editAlien.ToJson, 'application/json', 200); + finally + editAlien.Free; + end; + finally + jData.Free; + end; + end + else + AResponse.Send('Invalid request', 'text/plain', 400); +end; + +procedure TRoutePetAlien.Delete(const aPetId: integer; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +begin + pets.Delete(aPetId); + AResponse.Send('deleted ' + IntToStr(aPetId), 'text/plain', 200); +end; + +procedure TRoutePetAlien.DoRequest(ASender: TObject; ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse); +var + tmpId : integer; +begin + if HandleOptions(ARoute, ARequest, AResponse) then + exit; + AddStandardHeaders(AResponse); + + tmpId := 0; + if (Length(ARoute.Segments) >= 1) then + tmpId := StrToInt(RightStr(ARoute.Segments[Length(ARoute.Segments)-1], Length(ARoute.Segments[Length(ARoute.Segments)-1]) - 1 )); + + if ARequest.Method = 'POST' then + Post(ARoute, ARequest, AResponse) + else if ARequest.Method = 'PUT' then + Put(ARoute, ARequest, AResponse) + else if ARequest.Method = 'DELETE' then + Delete(tmpId, ARoute, ARequest, AResponse); +end; + +procedure TRoutePetAlien.AfterConstruction; +begin + Methods:= [rmPOST, rmPUT, rmDELETE, rmOPTIONS]; + Pattern := 'alienpet(([/])|(/[0-9]+))?'; +end; + + +initialization + pets := TAlienPetsArchive.Create; + InitAlienPetsArchive; + +finalization + pets.Free; + +end. diff --git a/Examples/LCL/Tutorial2/standardheaders.pas b/Examples/LCL/Tutorial2/standardheaders.pas new file mode 100644 index 0000000..9a474af --- /dev/null +++ b/Examples/LCL/Tutorial2/standardheaders.pas @@ -0,0 +1,82 @@ +unit standardheaders; + +{$mode ObjFPC}{$H+} + +interface + +uses + BrookHTTPResponse, + BrookURLRouter, + BrookUtility; + +procedure AddStandardHeaders(AResponse: TBrookHTTPResponse); +procedure AddStandardHeadersForOptions(AResponse: TBrookHTTPResponse; ARoute: TBrookURLRoute); + +implementation + +procedure AddStandardHeaders(AResponse: TBrookHTTPResponse); +begin + //{$IFDEF DEVELOPMENT} + AResponse.Headers.Add('Access-Control-Allow-Origin', '*'); + //{$ENDIF} + AResponse.Headers.Add('Server', 'Alien puppies server'); + AResponse.Headers.Add('Keep-Alive', 'timeout=5, max=99'); + AResponse.Headers.Add('Connection', 'Keep-Alive'); + AResponse.Headers.Add('X-Frame-Options', 'SAMEORIGIN'); // https://stackoverflow.com/questions/27358966/how-can-i-set-x-frame-options-on-an-iframe +end; + +procedure AddStandardHeadersForOptions(AResponse: TBrookHTTPResponse; ARoute: TBrookURLRoute); +var + mt, sep : String; +begin + AddStandardHeaders(AResponse); + + if ARoute.Methods = [] then + mt := 'GET, PUT, POST, OPTIONS, HEAD' + else + begin + mt := ''; + sep := ''; + if rmGet in ARoute.Methods then + begin + mt := mt + sep + 'GET'; + sep := ', '; + end; + if rmPOST in ARoute.Methods then + begin + mt := mt + sep + 'POST'; + sep := ', '; + end; + if rmPUT in ARoute.Methods then + begin + mt := mt + sep + 'PUT'; + sep := ', '; + end; + if rmDELETE in ARoute.Methods then + begin + mt := mt + sep + 'DELETE'; + sep := ', '; + end; + if rmPATCH in ARoute.Methods then + begin + mt := mt + sep + 'PATCH'; + sep := ', '; + end; + if rmOPTIONS in ARoute.Methods then + begin + mt := mt + sep + 'OPTIONS'; + sep := ', '; + end; + if rmHEAD in ARoute.Methods then + begin + mt := mt + sep + 'HEAD'; + sep := ', '; + end; + end; + + AResponse.Headers.Add('Access-Control-Allow-Methods', mt); + AResponse.Headers.Add('Access-Control-Allow-Headers', 'x-requested-with, content-type, authorization'); +end; + +end. + diff --git a/Examples/LCL/Tutorial2/standardresponses.pas b/Examples/LCL/Tutorial2/standardresponses.pas new file mode 100644 index 0000000..8b935c0 --- /dev/null +++ b/Examples/LCL/Tutorial2/standardresponses.pas @@ -0,0 +1,32 @@ +unit standardresponses; + +{$mode ObjFPC}{$H+} + +interface + +uses + BrookHTTPResponse, + BrookHTTPRequest, + BrookURLRouter; + +function HandleOptions(ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse): boolean; + +implementation + +uses + standardheaders; + +function HandleOptions(ARoute: TBrookURLRoute; ARequest: TBrookHTTPRequest; AResponse: TBrookHTTPResponse): boolean; +begin + Result := false; + if ARequest.Method = 'OPTIONS' then + begin + AddStandardHeadersForOptions(AResponse, ARoute); + AResponse.Send('', 'text/html', 200); + Result := true; + end; +end; + + +end. +