-----------------------------------------------------------------------
--  gen-artifacts-xmi -- UML-XMI artifact for Code Generator
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with DOM.Core;
with Gen.Model.Packages;
with Gen.Model.XMI;

--  The Gen.Artifacts.XMI package is an artifact for the generation of Ada code
--  from an UML XMI description.
package Gen.Artifacts.XMI is

   --  ------------------------------
   --  UML XMI artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   overriding
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class);

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Read the UML/XMI model file.
   procedure Read_Model (Handler : in out Artifact;
                         File    : in String;
                         Context : in out Generator'Class);

   --  Read the UML configuration files that define the pre-defined types, stereotypes
   --  and other components used by a model.  These files are XMI files as well.
   --  All the XMI files in the UML config directory are read.
   procedure Read_UML_Configuration (Handler : in out Artifact;
                                     Context : in out Generator'Class);

private

   type Artifact is new Gen.Artifacts.Artifact with record
      Nodes      : aliased Gen.Model.XMI.UML_Model;
      Has_Config : Boolean := False;

      --  Stereotype which triggers the generation of database table.
      Table_Stereotype      : Gen.Model.XMI.Stereotype_Element_Access;
      PK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      FK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      Data_Model_Stereotype : Gen.Model.XMI.Stereotype_Element_Access;
      Nullable_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;
      Not_Null_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;

      --  Tag definitions which control the generation.
      Has_List_Tag          : Gen.Model.XMI.Tag_Definition_Element_Access;
      Table_Name_Tag        : Gen.Model.XMI.Tag_Definition_Element_Access;

      --  Stereotype which triggers the generation of AWA bean types.
      Bean_Stereotype  : Gen.Model.XMI.Stereotype_Element_Access;
   end record;

end Gen.Artifacts.XMI;

-----------------------------------------------------------------------
--  gen-artifacts-xmi -- UML-XMI artifact for Code Generator
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with DOM.Core;
with Gen.Model.Packages;
with Gen.Model.XMI;

--  The Gen.Artifacts.XMI package is an artifact for the generation of Ada code
--  from an UML XMI description.
package Gen.Artifacts.XMI is

   --  ------------------------------
   --  UML XMI artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   overriding
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class);

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

   --  Read the UML/XMI model file.
   procedure Read_Model (Handler : in out Artifact;
                         File    : in String;
                         Context : in out Generator'Class);

   --  Read the UML configuration files that define the pre-defined types, stereotypes
   --  and other components used by a model.  These files are XMI files as well.
   --  All the XMI files in the UML config directory are read.
   procedure Read_UML_Configuration (Handler : in out Artifact;
                                     Context : in out Generator'Class);

private

   type Artifact is new Gen.Artifacts.Artifact with record
      Nodes      : aliased Gen.Model.XMI.UML_Model;
      Has_Config : Boolean := False;

      --  Stereotype which triggers the generation of database table.
      Table_Stereotype      : Gen.Model.XMI.Stereotype_Element_Access;
      PK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      FK_Stereotype         : Gen.Model.XMI.Stereotype_Element_Access;
      Data_Model_Stereotype : Gen.Model.XMI.Stereotype_Element_Access;
      Nullable_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;
      Not_Null_Stereotype   : Gen.Model.XMI.Stereotype_Element_Access;
      Use_FK_Stereotype     : Gen.Model.XMI.Stereotype_Element_Access;

      --  Tag definitions which control the generation.
      Has_List_Tag          : Gen.Model.XMI.Tag_Definition_Element_Access;
      Table_Name_Tag        : Gen.Model.XMI.Tag_Definition_Element_Access;

      --  Stereotype which triggers the generation of AWA bean types.
      Bean_Stereotype  : Gen.Model.XMI.Stereotype_Element_Access;
   end record;

end Gen.Artifacts.XMI;

Add the use foreign key stereotype

Add the use foreign key stereotype


-----------------------------------------------------------------------
--  gen-commands-docs -- Extract and generate documentation for the project
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with GNAT.Command_Line;

with Ada.Text_IO;

with Gen.Artifacts.Docs;
with Gen.Model.Packages;
package body Gen.Commands.Docs is

   use GNAT.Command_Line;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      Doc : Gen.Artifacts.Docs.Artifact;
      M   : Gen.Model.Packages.Model_Definition;
   begin
      Generator.Read_Project ("dynamo.xml", False);

      --  Setup the target directory where the distribution is created.
      declare
         Target_Dir : constant String := Get_Argument;
      begin
         if Target_Dir'Length = 0 then
            Generator.Error ("Missing target directory");
            return;
         end if;
         Generator.Set_Result_Directory (Target_Dir);
      end;
--
--        --  Read the package description.
--        declare
--           Package_File : constant String := Get_Argument;
--        begin
--           if Package_File'Length > 0 then
--              Gen.Generator.Read_Package (Generator, Package_File);
--           else
--              Gen.Generator.Read_Package (Generator, "package.xml");
--           end if;
--        end;

      Doc.Prepare (M, Generator);
--        --  Run the generation.
--        Gen.Generator.Prepare (Generator);
--        Gen.Generator.Generate_All (Generator);
--        Gen.Generator.Finish (Generator);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("build-doc: Extract and generate the project documentation");
      Put_Line ("Usage: build-doc");
      New_Line;
      Put_Line ("  Extract the documentation from the project source files and generate the");
      Put_Line ("  project documentation.  The following files are scanned:");
      Put_Line ("    - Ada specifications (src/*.ads)");
      Put_Line ("    - XML configuration files (config/*.xml)");
      Put_Line ("    - XML database model files (db/*.xml)");
   end Help;

end Gen.Commands.Docs;

-----------------------------------------------------------------------
--  gen-commands-docs -- Extract and generate documentation for the project
--  Copyright (C) 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with GNAT.Command_Line;

with Ada.Text_IO;

with Gen.Artifacts.Docs;
with Gen.Model.Packages;
package body Gen.Commands.Docs is

   use GNAT.Command_Line;

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);

      Doc : Gen.Artifacts.Docs.Artifact;
      M   : Gen.Model.Packages.Model_Definition;
   begin
      Generator.Read_Project ("dynamo.xml", False);

      --  Setup the target directory where the distribution is created.
      declare
         Target_Dir : constant String := Get_Argument;
      begin
         if Target_Dir'Length = 0 then
            Generator.Error ("Missing target directory");
            return;
         end if;
         Generator.Set_Result_Directory (Target_Dir);
      end;

      Doc.Prepare (M, Generator);
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd       : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd, Generator);
      use Ada.Text_IO;
   begin
      Put_Line ("build-doc: Extract and generate the project documentation");
      Put_Line ("Usage: build-doc");
      New_Line;
      Put_Line ("  Extract the documentation from the project source files and generate the");
      Put_Line ("  project documentation.  The following files are scanned:");
      Put_Line ("    - Ada specifications (src/*.ads)");
      Put_Line ("    - XML configuration files (config/*.xml)");
      Put_Line ("    - XML database model files (db/*.xml)");
   end Help;

end Gen.Commands.Docs;

Remove unused commented code

Remove unused commented code


-----------------------------------------------------------------------
--  gen-commands-page -- Page creation command for dynamo
--  Copyright (C) 2011, 2012, 2013, 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with Util.Strings;

package body Gen.Commands.Page is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use GNAT.Command_Line;
      use Ada.Strings.Unbounded;

      function Get_Layout return String;
      function Get_Name return String;

      Dir    : constant String := Generator.Get_Result_Directory & "web/";

      function Get_Name return String is
         Name : constant String := Get_Argument;
         Pos  : constant Natural := Util.Strings.Rindex (Name, '.');
      begin
         if Pos = 0 then
            return Name;
         elsif Name (Pos .. Name'Last) = ".xhtml" then
            return Name (Name'First .. Pos - 1);
         elsif Name (Pos .. Name'Last) = ".html" then
            return Name (Name'First .. Pos - 1);
         else
            return Name;
         end if;
      end Get_Name;

      function Get_Layout return String is
         Layout : constant String := Get_Argument;
      begin
         if Layout'Length = 0 then
            return "layout";
         end if;
         if Ada.Directories.Exists (Dir & "WEB-INF/layouts/" & Layout & ".xhtml") then
            return Layout;
         end if;

         Generator.Error ("Layout file {0} not found.  Using 'layout' instead.", Layout);
         return "layout";
      end Get_Layout;

      Name   : constant String := Get_Name;
      Layout : constant String := Get_Layout;
   begin
      if Name'Length = 0 then
         Gen.Commands.Usage;
         return;
      end if;

      Generator.Set_Force_Save (False);
      Generator.Set_Result_Directory (Dir);
      Generator.Set_Global ("pageName", Name);
      Generator.Set_Global ("layout", Layout);
      Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "page");
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use Ada.Text_IO;
      use Ada.Directories;

      Path    : constant String := Generator.Get_Result_Directory & "web/WEB-INF/layouts";
      Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
      Search  : Search_Type;
      Ent     : Directory_Entry_Type;
   begin
      Put_Line ("add-page: Add a new web page to the application");
      Put_Line ("Usage: add-page NAME [LAYOUT]");
      New_Line;
      Put_Line ("  The web page is an XHTML file created under the 'web' directory.");
      Put_Line ("  The NAME can contain a directory that will be created if necessary.");
      Put_Line ("  The new web page can be configured to use the given layout.");
      Put_Line ("  The layout file must exist to be used.  The default layout is 'layout'.");
      Put_Line ("  You can create a new layout with 'add-layout' command.");
      Put_Line ("  You can also write your layout by adding an XHTML file in the directory:");
      Put_Line ("     " & Path);
      if Exists (Path) then
         New_Line;
         Put_Line ("  Available layouts:");

         Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Name   : constant String := Simple_Name (Ent);
               Layout : constant String := Base_Name (Name);
            begin
               Put_Line ("      " & Layout);
            end;
         end loop;
      end if;
      New_Line;
      Put_Line ("  The following files are generated:");
      Put_Line ("    web/<name>.xhtml");
   end Help;

end Gen.Commands.Page;

-----------------------------------------------------------------------
--  gen-commands-page -- Page creation command for dynamo
--  Copyright (C) 2011, 2012, 2013, 2014 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with Util.Strings;

package body Gen.Commands.Page is

   --  ------------------------------
   --  Execute the command with the arguments.
   --  ------------------------------
   procedure Execute (Cmd       : in Command;
                      Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use GNAT.Command_Line;
      use Ada.Strings.Unbounded;

      function Get_Layout return String;
      function Get_Name return String;

      Dir    : constant String := Generator.Get_Result_Directory & "web/";

      function Get_Name return String is
         Name : constant String := Get_Argument;
         Pos  : constant Natural := Util.Strings.Rindex (Name, '.');
      begin
         if Pos = 0 then
            return Name;
         elsif Name (Pos .. Name'Last) = ".xhtml" then
            return Name (Name'First .. Pos - 1);
         elsif Name (Pos .. Name'Last) = ".html" then
            return Name (Name'First .. Pos - 1);
         else
            return Name;
         end if;
      end Get_Name;

      function Get_Layout return String is
         Layout : constant String := Get_Argument;
      begin
         if Layout'Length = 0 then
            return "layout";
         end if;
         if Ada.Directories.Exists (Dir & "WEB-INF/layouts/" & Layout & ".xhtml") then
            return Layout;
         end if;

         Generator.Info ("Layout file {0} not found.", Layout);
         return Layout;
      end Get_Layout;

      Name   : constant String := Get_Name;
      Layout : constant String := Get_Layout;
   begin
      if Name'Length = 0 then
         Gen.Commands.Usage;
         return;
      end if;

      Generator.Set_Force_Save (False);
      Generator.Set_Result_Directory (Dir);
      Generator.Set_Global ("pageName", Name);
      Generator.Set_Global ("layout", Layout);
      Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "page");
   end Execute;

   --  ------------------------------
   --  Write the help associated with the command.
   --  ------------------------------
   procedure Help (Cmd : in Command;
                   Generator : in out Gen.Generator.Handler) is
      pragma Unreferenced (Cmd);
      use Ada.Text_IO;
      use Ada.Directories;

      Path    : constant String := Generator.Get_Result_Directory & "web/WEB-INF/layouts";
      Filter  : constant Filter_Type := (Ordinary_File => True, others => False);
      Search  : Search_Type;
      Ent     : Directory_Entry_Type;
   begin
      Put_Line ("add-page: Add a new web page to the application");
      Put_Line ("Usage: add-page NAME [LAYOUT]");
      New_Line;
      Put_Line ("  The web page is an XHTML file created under the 'web' directory.");
      Put_Line ("  The NAME can contain a directory that will be created if necessary.");
      Put_Line ("  The new web page can be configured to use the given layout.");
      Put_Line ("  The layout file must exist to be used.  The default layout is 'layout'.");
      Put_Line ("  You can create a new layout with 'add-layout' command.");
      Put_Line ("  You can also write your layout by adding an XHTML file in the directory:");
      Put_Line ("     " & Path);
      if Exists (Path) then
         New_Line;
         Put_Line ("  Available layouts:");

         Start_Search (Search, Directory => Path, Pattern => "*.xhtml", Filter => Filter);
         while More_Entries (Search) loop
            Get_Next_Entry (Search, Ent);
            declare
               Name   : constant String := Simple_Name (Ent);
               Layout : constant String := Base_Name (Name);
            begin
               Put_Line ("      " & Layout);
            end;
         end loop;
      end if;
      New_Line;
      Put_Line ("  The following files are generated:");
      Put_Line ("    web/<name>.xhtml");
   end Help;

end Gen.Commands.Page;

Allow to use a layout that is located outside of the user WEB-INF directory


-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  Copyright (C) 2014 Stephane.Carrez
--  Written by Stephane.Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

pragma Ada_2012;

with Babel.Files;
with Babel.Files.Buffers;
with Babel.Stores;
with Babel.Filters;
package Babel.Strategies is

   type Strategy_Type is abstract limited new Babel.Files.File_Container with private;
   type Strategy_Type_Access is access all Strategy_Type'Class;

   --  Allocate a buffer to read the file content.
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access;

   --  Release the buffer that was allocated by Allocate_Buffer.
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access);

   --  Returns true if there is a directory that must be processed by the current strategy.
   function Has_Directory (Strategy : in Strategy_Type) return Boolean is abstract;

   --  Get the next directory that must be processed by the strategy.
   function Peek_Directory (Strategy : in out Strategy_Type) return String is abstract;

   procedure Scan (Strategy : in out Strategy_Type;
                   Path     : in String);

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Into     : in Babel.Files.Buffers.Buffer_Access);

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Content  : in Babel.Files.Buffers.Buffer_Access);

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Content  : in out Babel.Files.Buffers.Buffer_Access);

   procedure Execute (Strategy : in out Strategy_Type) is abstract;

   --  Set the file filters that will be used when scanning the read store.
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access);

   --  Set the read and write stores that the strategy will use.
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access);

   --  Set the buffer pool to be used by Allocate_Buffer.
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access);

private

   type Strategy_Type is abstract limited new Babel.Files.File_Container with record
      Read_Store  : Babel.Stores.Store_Type_Access;
      Write_Store : Babel.Stores.Store_Type_Access;
      Filters     : Babel.Filters.Filter_Type_Access;
      Buffers     : Babel.Files.Buffers.Buffer_Pool_Access;
   end record;

end Babel.Strategies;

-----------------------------------------------------------------------
--  babel-strategies -- Strategies to backup files
--  Copyright (C) 2014 Stephane.Carrez
--  Written by Stephane.Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

pragma Ada_2012;

with Babel.Files;
with Babel.Files.Buffers;
with Babel.Stores;
with Babel.Filters;
package Babel.Strategies is

   type Strategy_Type is abstract limited new Babel.Files.File_Container with private;
   type Strategy_Type_Access is access all Strategy_Type'Class;

   --  Allocate a buffer to read the file content.
   function Allocate_Buffer (Strategy : in Strategy_Type) return Babel.Files.Buffers.Buffer_Access;

   --  Release the buffer that was allocated by Allocate_Buffer.
   procedure Release_Buffer (Strategy : in Strategy_Type;
                             Buffer   : in out Babel.Files.Buffers.Buffer_Access);

   --  Returns true if there is a directory that must be processed by the current strategy.
   function Has_Directory (Strategy : in Strategy_Type) return Boolean is abstract;

   --  Get the next directory that must be processed by the strategy.
   procedure Peek_Directory (Strategy  : in out Strategy_Type;
                             Directory : out Babel.Files.Directory_Type) is abstract;

   procedure Scan (Strategy : in out Strategy_Type;
                   Path     : in String);

   --  Read the file from the read store into the local buffer.
   procedure Read_File (Strategy : in Strategy_Type;
                        File     : in Babel.Files.File_Type;
                        Into     : in Babel.Files.Buffers.Buffer_Access);

   --  Write the file from the local buffer into the write store.
   procedure Write_File (Strategy : in Strategy_Type;
                         File     : in Babel.Files.File_Type;
                         Content  : in Babel.Files.Buffers.Buffer_Access);

   --  Backup the file from the local buffer into the write store.
   procedure Backup_File (Strategy : in Strategy_Type;
                          File     : in Babel.Files.File_Type;
                          Content  : in out Babel.Files.Buffers.Buffer_Access);

   procedure Execute (Strategy : in out Strategy_Type) is abstract;

   --  Set the file filters that will be used when scanning the read store.
   procedure Set_Filters (Strategy : in out Strategy_Type;
                          Filters  : in Babel.Filters.Filter_Type_Access);

   --  Set the read and write stores that the strategy will use.
   procedure Set_Stores (Strategy : in out Strategy_Type;
                         Read     : in Babel.Stores.Store_Type_Access;
                         Write    : in Babel.Stores.Store_Type_Access);

   --  Set the buffer pool to be used by Allocate_Buffer.
   procedure Set_Buffers (Strategy : in out Strategy_Type;
                          Buffers  : in Babel.Files.Buffers.Buffer_Pool_Access);

private

   type Strategy_Type is abstract limited new Babel.Files.File_Container with record
      Read_Store  : Babel.Stores.Store_Type_Access;
      Write_Store : Babel.Stores.Store_Type_Access;
      Filters     : Babel.Filters.Filter_Type_Access;
      Buffers     : Babel.Files.Buffers.Buffer_Pool_Access;
   end record;

end Babel.Strategies;

Change the Peek_Directory to a procedure


-----------------------------------------------------------------------
--  awa-users-model -- User management module
--  Copyright (C) 2009, 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWA.Modules.Beans;
with AWA.Modules.Get;

with AWA.Applications;
with AWA.Users.Beans;

with Util.Log.Loggers;
package body AWA.Users.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Users.Module");

   package Register is new AWA.Modules.Beans (Module => User_Module,
                                              Module_Access => User_Module_Access);

   --  ------------------------------
   --  Initialize the user module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out User_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the users module");

      --  Setup the resource bundles.
      App.Register ("userMsg", "users");

      --  Register the OpenID servlets.
      App.Add_Servlet (Name   => "openid-auth",
                       Server => Plugin.Auth'Unchecked_Access);
      App.Add_Servlet (Name   => "openid-verify",
                       Server => Plugin.Verify_Auth'Unchecked_Access);

      --  Setup the verify access key filter.
      App.Add_Filter ("verify-access-key", Plugin.Key_Filter'Unchecked_Access);
      App.Add_Filter ("auth-filter", Plugin.Auth_Filter'Unchecked_Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Authenticate_Bean",
                         Handler => AWA.Users.Beans.Create_Authenticate_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Current_User_Bean",
                         Handler => AWA.Users.Beans.Create_Current_User_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Create the user manager when everything is initialized.
      Plugin.Manager := Plugin.Create_User_Manager;
   end Initialize;

   --  ------------------------------
   --  Get the user manager.
   --  ------------------------------
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
   begin
      return Plugin.Manager;
   end Get_User_Manager;

   --  ------------------------------
   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   --  ------------------------------
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
      Result : constant Services.User_Service_Access := new Services.User_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_User_Manager;

   --  ------------------------------
   --  Get the user module instance associated with the current application.
   --  ------------------------------
   function Get_User_Module return User_Module_Access is
      function Get is new AWA.Modules.Get (User_Module, User_Module_Access, NAME);
   begin
      return Get;
   end Get_User_Module;

   --  ------------------------------
   --  Get the user manager instance associated with the current application.
   --  ------------------------------
   function Get_User_Manager return Services.User_Service_Access is
      Module : constant User_Module_Access := Get_User_Module;
   begin
      if Module = null then
         Log.Error ("There is no active User_Module");
         return null;
      else
         return Module.Get_User_Manager;
      end if;
   end Get_User_Manager;

end AWA.Users.Modules;

-----------------------------------------------------------------------
--  awa-users-model -- User management module
--  Copyright (C) 2009, 2010, 2011, 2012, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with AWA.Modules.Beans;
with AWA.Modules.Get;

with AWA.Applications;
with AWA.Users.Beans;

with Util.Log.Loggers;
package body AWA.Users.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Users.Module");

   package Register is new AWA.Modules.Beans (Module => User_Module,
                                              Module_Access => User_Module_Access);

   --  ------------------------------
   --  Initialize the user module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out User_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the users module");

      --  Setup the resource bundles.
      App.Register ("userMsg", "users");

      --  Register the OpenID servlets.
      App.Add_Servlet (Name   => "openid-auth",
                       Server => Plugin.Auth'Unchecked_Access);
      App.Add_Servlet (Name   => "openid-verify",
                       Server => Plugin.Verify_Auth'Unchecked_Access);

      --  Setup the verify access key filter.
      App.Add_Filter ("verify-access-key", Plugin.Key_Filter'Unchecked_Access);
      App.Add_Filter ("auth-filter", Plugin.Auth_Filter'Unchecked_Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Authenticate_Bean",
                         Handler => AWA.Users.Beans.Create_Authenticate_Bean'Access);

      Register.Register (Plugin  => Plugin,
                         Name    => "AWA.Users.Beans.Current_User_Bean",
                         Handler => AWA.Users.Beans.Create_Current_User_Bean'Access);

      AWA.Modules.Module (Plugin).Initialize (App, Props);
   end Initialize;

   --  ------------------------------
   --  Configures the module after its initialization and after having read its XML configuration.
   --  ------------------------------
   overriding
   procedure Configure (Plugin : in out User_Module;
                        Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      --  Create the user manager when everything is initialized.
      Plugin.Manager := Plugin.Create_User_Manager;
   end Configure;

   --  ------------------------------
   --  Get the user manager.
   --  ------------------------------
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
   begin
      return Plugin.Manager;
   end Get_User_Manager;

   --  ------------------------------
   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   --  ------------------------------
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access is
      Result : constant Services.User_Service_Access := new Services.User_Service;
   begin
      Result.Initialize (Plugin);
      return Result;
   end Create_User_Manager;

   --  ------------------------------
   --  Get the user module instance associated with the current application.
   --  ------------------------------
   function Get_User_Module return User_Module_Access is
      function Get is new AWA.Modules.Get (User_Module, User_Module_Access, NAME);
   begin
      return Get;
   end Get_User_Module;

   --  ------------------------------
   --  Get the user manager instance associated with the current application.
   --  ------------------------------
   function Get_User_Manager return Services.User_Service_Access is
      Module : constant User_Module_Access := Get_User_Module;
   begin
      if Module = null then
         Log.Error ("There is no active User_Module");
         return null;
      else
         return Module.Get_User_Manager;
      end if;
   end Get_User_Manager;

end AWA.Users.Modules;

Fix configuration of users module by creating the user manager instance after the configuration is obtained


-----------------------------------------------------------------------
--  awa-users-module -- User management module
--  Copyright (C) 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ASF.Applications;

with Security.Openid.Servlets;

with AWA.Modules;
with AWA.Users.Services;
with AWA.Users.Filters;
with AWA.Users.Servlets;

--  == Introduction ==
--  The Users.Module manages the creation, update, removal and authentication of users
--  in an application.  The module provides the foundations for user management in
--  a web application.
--
--  A user can register himself by using a subscription form.  In that case, a verification mail
--  is sent and the user has to follow the verification link defined in the mail to finish
--  the registration process.  The user will authenticate using a password.
--
--  A user can also use an OpenID account and be automatically registered.
--
--  A user can have one or several permissions that allow to protect the application data.
--  User permissions are managed by the Permissions.Module.
--
--  == Configuration ==
--  The *users* module uses a set of configuration properties to configure the OpenID
--  integration.
--
--  @see AWA.Users.Services
package AWA.Users.Modules is

   NAME : constant String := "users";

   type User_Module is new AWA.Modules.Module with private;
   type User_Module_Access is access all User_Module'Class;

   --  Initialize the user module.
   overriding
   procedure Initialize (Plugin : in out User_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the user manager.
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Get the user module instance associated with the current application.
   function Get_User_Module return User_Module_Access;

   --  Get the user manager instance associated with the current application.
   function Get_User_Manager return Services.User_Service_Access;

private

   type User_Module is new AWA.Modules.Module with record
      Manager     : Services.User_Service_Access := null;
      Key_Filter  : aliased AWA.Users.Filters.Verify_Filter;
      Auth_Filter : aliased AWA.Users.Filters.Auth_Filter;
      Auth        : aliased Security.Openid.Servlets.Request_Auth_Servlet;
      Verify_Auth : aliased AWA.Users.Servlets.Verify_Auth_Servlet;
   end record;

end AWA.Users.Modules;

-----------------------------------------------------------------------
--  awa-users-module -- User management module
--  Copyright (C) 2009, 2010, 2011, 2012 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with ASF.Applications;

with Security.Openid.Servlets;

with AWA.Modules;
with AWA.Users.Services;
with AWA.Users.Filters;
with AWA.Users.Servlets;

--  == Introduction ==
--  The Users.Module manages the creation, update, removal and authentication of users
--  in an application.  The module provides the foundations for user management in
--  a web application.
--
--  A user can register himself by using a subscription form.  In that case, a verification mail
--  is sent and the user has to follow the verification link defined in the mail to finish
--  the registration process.  The user will authenticate using a password.
--
--  A user can also use an OpenID account and be automatically registered.
--
--  A user can have one or several permissions that allow to protect the application data.
--  User permissions are managed by the Permissions.Module.
--
--  == Configuration ==
--  The *users* module uses a set of configuration properties to configure the OpenID
--  integration.
--
--  @include awa-users-services.ads
--  @include User.hbm.xml
package AWA.Users.Modules is

   NAME : constant String := "users";

   type User_Module is new AWA.Modules.Module with private;
   type User_Module_Access is access all User_Module'Class;

   --  Initialize the user module.
   overriding
   procedure Initialize (Plugin : in out User_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the user manager.
   function Get_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Create a user manager.  This operation can be overriden to provide another
   --  user service implementation.
   function Create_User_Manager (Plugin : in User_Module) return Services.User_Service_Access;

   --  Get the user module instance associated with the current application.
   function Get_User_Module return User_Module_Access;

   --  Get the user manager instance associated with the current application.
   function Get_User_Manager return Services.User_Service_Access;

private

   type User_Module is new AWA.Modules.Module with record
      Manager     : Services.User_Service_Access := null;
      Key_Filter  : aliased AWA.Users.Filters.Verify_Filter;
      Auth_Filter : aliased AWA.Users.Filters.Auth_Filter;
      Auth        : aliased Security.Openid.Servlets.Request_Auth_Servlet;
      Verify_Auth : aliased AWA.Users.Servlets.Verify_Auth_Servlet;
   end record;

end AWA.Users.Modules;

Integrate the data model and user's bean in the documentation


-----------------------------------------------------------------------
--  Sessions Tests - Unit tests for ASF.Sessions
--  Copyright (C) 2010, 2011, 2012, 2013, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Routes.Servlets;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   --  ------------------------------
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String) is
      use type ASF.Routes.Route_Type_Access;

      Dispatcher : constant Request_Dispatcher
        := Ctx.Get_Request_Dispatcher (Path => URI);
      Req        : ASF.Requests.Mockup.Request;
      Resp       : ASF.Responses.Mockup.Response;
      Result     : Unbounded_String;
   begin
      T.Assert (Dispatcher.Context.Get_Route /= null, "No mapping found for " & URI);

      Req.Set_Request_URI ("test1");
      Req.Set_Method ("GET");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, Servlet_Path, Req.Get_Servlet_Path, "Invalid servlet path");
      Assert_Equals (T, Path_Info, Req.Get_Path_Info,
                     "The request path info is invalid");

      --  Check the response after the Test_Servlet1.Do_Get method execution.
      Resp.Read_Content (Result);
      Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
      Assert_Equals (T, "URI: test1", Result, "Invalid content");

      Req.Set_Method ("POST");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                     "Invalid status for an operation not implemented");
   end Check_Request;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/home/test.jsf", "/home/test.jsf", "");
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Servlet_Path (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/p1/p2/p3/home/test.html", "/p1/p2/p3", "/home/test.html");
   end Test_Servlet_Path;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access) is
      use type ASF.Routes.Route_Type_Access;

      Disp  : constant Request_Dispatcher := Ctx.Get_Request_Dispatcher (URI);
      Route : constant ASF.Routes.Route_Type_Access := Disp.Context.Get_Route;
   begin
      if Server = null then
         T.Assert (Route = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Route /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Route.all in ASF.Routes.Servlets.Servlet_Route_Type'Class,
                   "The route is not a Servlet route");
         T.Assert (ASF.Routes.Servlets.Servlet_Route_Type'Class (Route.all).Servlet = Server,
                   "Invalid mapping returned for URI: " & URI);
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      --  Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (extension)");
--        end;

--        T.Assert (Map /= null, "No mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (path)");
--        end;
--
--        T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

   package Caller is new Util.Test_Caller (Test, "Servlets");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Get_Servlet_Path",
                       Test_Servlet_Path'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

-----------------------------------------------------------------------
--  Sessions Tests - Unit tests for ASF.Sessions
--  Copyright (C) 2010, 2011, 2012, 2013, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Measures;

with ASF.Applications;
with ASF.Streams;
with ASF.Routes.Servlets;
with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Filters.Dump;
package body ASF.Servlets.Tests is

   use Util.Tests;

   procedure Do_Get (Server   : in Test_Servlet1;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);

      Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
   begin
      Output.Write ("URI: " & Request.Get_Request_URI);
      Response.Set_Status (Responses.SC_OK);
   end Do_Get;

   procedure Do_Post (Server   : in Test_Servlet2;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
   begin
      null;
   end Do_Post;

   S1 : aliased Test_Servlet1;
   S2 : aliased Test_Servlet2;

   --  ------------------------------
   --  Check that the request is done on the good servlet and with the correct servlet path
   --  and path info.
   --  ------------------------------
   procedure Check_Request (T            : in out Test;
                            Ctx          : in Servlet_Registry;
                            URI          : in String;
                            Servlet_Path : in String;
                            Path_Info    : in String) is
      use type ASF.Routes.Route_Type_Access;

      Dispatcher : constant Request_Dispatcher
        := Ctx.Get_Request_Dispatcher (Path => URI);
      Req        : ASF.Requests.Mockup.Request;
      Resp       : ASF.Responses.Mockup.Response;
      Result     : Unbounded_String;
   begin
      T.Assert (Dispatcher.Context.Get_Route /= null, "No mapping found for " & URI);

      Req.Set_Request_URI ("test1");
      Req.Set_Method ("GET");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, Servlet_Path, Req.Get_Servlet_Path, "Invalid servlet path");
      Assert_Equals (T, Path_Info, Req.Get_Path_Info,
                     "The request path info is invalid");

      --  Check the response after the Test_Servlet1.Do_Get method execution.
      Resp.Read_Content (Result);
      Assert_Equals (T, ASF.Responses.SC_OK, Resp.Get_Status, "Invalid status");
      Assert_Equals (T, "URI: test1", Result, "Invalid content");

      Req.Set_Method ("POST");
      Forward (Dispatcher, Req, Resp);

      Assert_Equals (T, ASF.Responses.SC_METHOD_NOT_ALLOWED, Resp.Get_Status,
                     "Invalid status for an operation not implemented");
   end Check_Request;

   --  ------------------------------
   --  Test request dispatcher and servlet invocation
   --  ------------------------------
   procedure Test_Request_Dispatcher (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/home/test.jsf", "/home/test.jsf", "");
   end Test_Request_Dispatcher;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Servlet_Path (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");

      Ctx.Add_Mapping (Pattern => "/p1/p2/p3/*", Name => "Faces");

      Check_Request (T, Ctx, "/p1/p2/p3/home/test.html", "/p1/p2/p3", "/home/test.html");
   end Test_Servlet_Path;

   --  ------------------------------
   --  Test mapping and servlet path on a request.
   --  ------------------------------
   procedure Test_Filter_Mapping (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
      S2  : aliased Test_Servlet2;
      F1  : aliased ASF.Filters.Dump.Dump_Filter;
      F2  : aliased ASF.Filters.Dump.Dump_Filter;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
      Ctx.Add_Servlet ("Json", S2'Unchecked_Access);
      Ctx.Add_Filter ("Dump", F1'Unchecked_Access);
      Ctx.Add_Filter ("Dump2", F2'Unchecked_Access);
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.json", Name => "Json");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/file.html", Name => "Dump");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/result/test.html", Name => "Dump");
      Ctx.Add_Filter_Mapping (Pattern => "/dump/result/test.html", Name => "Dump2");
      Ctx.Start;
      T.Check_Mapping (Ctx, "test.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "file.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "/dump/test.html", S1'Unchecked_Access);
      T.Check_Mapping (Ctx, "/dump/file.html", S1'Unchecked_Access, 1);
      T.Check_Mapping (Ctx, "/dump/result/test.html", S1'Unchecked_Access, 2);
      T.Check_Mapping (Ctx, "test.json", S2'Unchecked_Access);
   end Test_Filter_Mapping;

   --  ------------------------------
   --  Test add servlet
   --  ------------------------------
   procedure Test_Add_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;

      S1  : aliased Test_Servlet1;
   begin
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      Assert_Equals (T, "Faces", S1.Get_Name, "Invalid name for the servlet");

      begin
         Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);
         T.Assert (False, "No exception raised if the servlet is registered several times");

      exception
         when Servlet_Error =>
            null;
      end;
   end Test_Add_Servlet;

   --  ------------------------------
   --  Test getting a resource path
   --  ------------------------------
   procedure Test_Get_Resource (T : in out Test) is
      Ctx : Servlet_Registry;

      Conf  : Applications.Config;
      S1    : aliased Test_Servlet1;
      Dir   : constant String := "regtests/files";
      Path  : constant String := Util.Tests.Get_Path (Dir);
   begin
      Conf.Load_Properties ("regtests/view.properties");
      Conf.Set ("view.dir", Path);
      Ctx.Set_Init_Parameters (Conf);
      Ctx.Add_Servlet ("Faces", S1'Unchecked_Access);

      --  Resource exist, check the returned path.
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text.xhtml");
      begin
         Assert_Matches (T, ".*/regtests/files/tests/form-text.xhtml",
                         P, "Invalid resource path");
      end;

      --  Resource does not exist
      declare
         P : constant String := Ctx.Get_Resource ("/tests/form-text-missing.xhtml");
      begin
         Assert_Equals (T, "", P, "Invalid resource path for missing resource");
      end;
   end Test_Get_Resource;

   --  ------------------------------
   --  Check that the mapping for the given URI matches the server.
   --  ------------------------------
   procedure Check_Mapping (T      : in out Test;
                            Ctx    : in Servlet_Registry;
                            URI    : in String;
                            Server : in Servlet_Access;
                            Filter : in Natural := 0) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Filters.Filter_List_Access;

      Disp  : constant Request_Dispatcher := Ctx.Get_Request_Dispatcher (URI);
      Route : constant ASF.Routes.Route_Type_Access := Disp.Context.Get_Route;
      Servlet_Route : ASF.Routes.Servlets.Servlet_Route_Type_Access;
   begin
      if Server = null then
         T.Assert (Route = null, "No mapping returned for URI: " & URI);
      else
         T.Assert (Route /= null, "A mapping is returned for URI: " & URI);
         T.Assert (Route.all in ASF.Routes.Servlets.Servlet_Route_Type'Class,
                   "The route is not a Servlet route");
         Servlet_Route := ASF.Routes.Servlets.Servlet_Route_Type'Class (Route.all)'Access;
         T.Assert (Servlet_Route.Servlet = Server,
                   "Invalid mapping returned for URI: " & URI);
         if Filter = 0 then
            T.Assert (Disp.Filters = null,
                      "Filters are configured for URI: " & URI);
         else
            T.Assert (Disp.Filters /= null, "No filter on the route URI: " & URI);
            Util.Tests.Assert_Equals (T, Filter, Disp.Filters'Length,
                                      "Invalid mapping returned for URI: " & URI);
         end if;
      end if;
   end Check_Mapping;

   --  ------------------------------
   --  Test session creation.
   --  ------------------------------
   procedure Test_Create_Servlet (T : in out Test) is
      Ctx : Servlet_Registry;
   begin
      Ctx.Add_Servlet (Name => "Faces", Server => S1'Access);
      Ctx.Add_Servlet (Name => "Text", Server => S2'Access);

      Ctx.Add_Mapping (Pattern => "*.jsf", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.html", Name => "Faces");
      Ctx.Add_Mapping (Pattern => "*.txt", Name => "Text");

      --  Ctx.Add_Mapping (Pattern => "/server", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/john/*", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/server/info", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list", Server => S1'Access);
      Ctx.Add_Mapping (Pattern => "/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/9/server/list2", Server => S2'Access);
      Ctx.Add_Mapping (Pattern => "/1/2/3/4/5/6/7/8/A/server/list2", Server => S1'Access);

      --  Ctx.Mappings.Dump_Map (" ");

      T.Check_Mapping (Ctx, "/joe/black/joe.jsf", S1'Access);
      T.Check_Mapping (Ctx, "/joe/black/joe.txt", S2'Access);
      T.Check_Mapping (Ctx, "/server/info", S1'Access);
      T.Check_Mapping (Ctx, "/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/9/server/list2", S2'Access);
      T.Check_Mapping (Ctx, "/1/2/3/4/5/6/7/8/A/server/list2", S1'Access);

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/joe/black/joe.jsf");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (extension)");
--        end;

--        T.Assert (Map /= null, "No mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S1'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

--        declare
--           St : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1000 loop
--              Map := Ctx.Find_Mapping (URI => "/1/2/3/4/5/6/7/8/9/server/list2");
--           end loop;
--           Util.Measures.Report (St, "Find 1000 mapping (path)");
--        end;
--
--        T.Assert (Map /= null, "No mapping for '/server/john/joe.jsf'");
--        T.Assert (Map.Servlet /= null, "No servlet for mapping for 'joe.jsf'");
--        T.Assert (Map.Servlet = S2'Access, "Invalid servlet");
      --        Util.Measures.Report (St, "10 Session create");

   end Test_Create_Servlet;

   package Caller is new Util.Test_Caller (Test, "Servlets");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is

   begin
      --  To document what is tested, register the test methods for each
      --  operation that is tested.
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Mapping,Find_Mapping",
                       Test_Create_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Servlet",
                       Test_Add_Servlet'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Request_Dispatcher",
                       Test_Request_Dispatcher'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Get_Resource",
                       Test_Get_Resource'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Get_Servlet_Path",
                       Test_Servlet_Path'Access);
      Caller.Add_Test (Suite, "Test ASF.Servlets.Add_Filter",
                       Test_Filter_Mapping'Access);
   end Add_Tests;

end ASF.Servlets.Tests;

Implement Test_Filter_Mapping to check several filter mappings


-----------------------------------------------------------------------
--  asf-beans-mappers -- Read XML managed bean declaratiosn
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
with EL.Contexts;

package ASF.Beans.Mappers is

   type Managed_Bean_Fields is (FIELD_NAME,
                                FIELD_CLASS,
                                FIELD_SCOPE,
                                FIELD_MANAGED_BEAN,
                                FIELD_PROPERTY,
                                FIELD_PROPERTY_NAME,
                                FIELD_PROPERTY_VALUE,
                                FIELD_PROPERTY_CLASS);

   type Bean_Factory_Access is access all ASF.Beans.Bean_Factory;

   type Managed_Bean is record
      Name         : Util.Beans.Objects.Object;
      Class        : Util.Beans.Objects.Object;
      Scope        : Scope_Type := REQUEST_SCOPE;
      Factory      : Bean_Factory_Access  := null;
      Params       : ASF.Beans.Parameter_Bean_Ref.Ref;
      Prop_Name    : Util.Beans.Objects.Object;
      Prop_Value   : Util.Beans.Objects.Object;
      Context      : EL.Contexts.ELContext_Access := null;
   end record;
   type Managed_Bean_Access is access all Managed_Bean;

   --  Set the field identified by Field with the Value.
   procedure Set_Member (MBean : in out Managed_Bean;
                         Field : in Managed_Bean_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  Setup the XML parser to read the managed bean definitions.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Factory : in Bean_Factory_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Managed_Bean;
   end Reader_Config;

private

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Managed_Bean,
                                               Element_Type_Access => Managed_Bean_Access,
                                               Fields              => Managed_Bean_Fields,
                                               Set_Member          => Set_Member);

end ASF.Beans.Mappers;

-----------------------------------------------------------------------
--  asf-beans-mappers -- Read XML managed bean declaratiosn
--  Copyright (C) 2010, 2011 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;
with Util.Serialize.IO.XML;
with EL.Contexts;

package ASF.Beans.Mappers is

   type Managed_Bean_Fields is (FIELD_NAME,
                                FIELD_CLASS,
                                FIELD_SCOPE,
                                FIELD_MANAGED_BEAN,
                                FIELD_PROPERTY,
                                FIELD_PROPERTY_NAME,
                                FIELD_PROPERTY_VALUE,
                                FIELD_PROPERTY_CLASS);

   type Bean_Factory_Access is access all ASF.Beans.Bean_Factory;

   type Managed_Bean is limited record
      Name         : Util.Beans.Objects.Object;
      Class        : Util.Beans.Objects.Object;
      Scope        : Scope_Type := REQUEST_SCOPE;
      Factory      : Bean_Factory_Access  := null;
      Params       : ASF.Beans.Parameter_Bean_Ref.Ref;
      Prop_Name    : Util.Beans.Objects.Object;
      Prop_Value   : Util.Beans.Objects.Object;
      Context      : EL.Contexts.ELContext_Access := null;
   end record;
   type Managed_Bean_Access is access all Managed_Bean;

   --  Set the field identified by Field with the Value.
   procedure Set_Member (MBean : in out Managed_Bean;
                         Field : in Managed_Bean_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  Setup the XML parser to read the managed bean definitions.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Factory : in Bean_Factory_Access;
      Context : in EL.Contexts.ELContext_Access;
   package Reader_Config is
      Config : aliased Managed_Bean;
   end Reader_Config;

private

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Managed_Bean,
                                               Element_Type_Access => Managed_Bean_Access,
                                               Fields              => Managed_Bean_Fields,
                                               Set_Member          => Set_Member);

end ASF.Beans.Mappers;

Use a limited record for Managed_Bean since we don't need to copy these objects and this reduces the code size