-----------------------------------------------------------------------
--  awa-applications-configs -- Read application configuration files
--  Copyright (C) 2011, 2012, 2015, 2017, 2018, 2020 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.Command_Line;
with Ada.Directories;
with Ada.Strings.Unbounded;

with Util.Strings;
with Util.Properties;
with Util.Beans.Objects;
with Util.Files;
with Util.Log.Loggers;
with Util.Serialize.IO.XML;

with ASF.Contexts.Faces;
with ASF.Applications.Main.Configs;

with Security.Policies;
with AWA.Events.Configs.Reader_Config;
with AWA.Services.Contexts;

package body AWA.Applications.Configs is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Applications.Configs");

   type Wallet_Manager is limited new Util.Properties.Implementation.Manager with record
      Wallet : Keystore.Properties.Manager;
      Props  : ASF.Applications.Config;
      Length : Positive;
      Prefix : String (1 .. MAX_PREFIX_LENGTH);
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Wallet_Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Wallet_Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   overriding
   function Exists (Self : in Wallet_Manager;
                    Name : in String)
                    return Boolean;

   --  Remove the property given its name.
   overriding
   procedure Remove (Self : in out Wallet_Manager;
                     Name : in String);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   overriding
   procedure Iterate (Self    : in Wallet_Manager;
                      Process : access procedure (Name : in String;
                                                  Item : in Util.Beans.Objects.Object));

   --  Deep copy of properties stored in 'From' to 'To'.
   function Create_Copy (Self : in Wallet_Manager)
                         return Util.Properties.Implementation.Manager_Access;

   package Shared_Manager is
     new Util.Properties.Implementation.Shared_Implementation (Wallet_Manager);

   subtype Property_Map is Shared_Manager.Manager;
   type Property_Map_Access is access all Property_Map;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Wallet_Manager;
                       Name : in String) return Util.Beans.Objects.Object is
      Prefixed_Name : constant String := From.Prefix (1 .. From.Length) & Name;
   begin
      if From.Wallet.Exists (Prefixed_Name) then
         declare
            Value : constant String := From.Wallet.Get (Prefixed_Name);
         begin
            return Util.Beans.Objects.To_Object (Value);
         end;
      else
         return From.Props.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wallet_Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      Prefixed_Name : constant String := From.Prefix (1 .. From.Length) & Name;
   begin
      if From.Wallet.Exists (Prefixed_Name) then
         From.Wallet.Set_Value (Prefixed_Name, Value);
      else
         From.Props.Set_Value (Name, Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Returns TRUE if the property exists.
   --  ------------------------------
   function Exists (Self : in Wallet_Manager;
                    Name : in String)
                    return Boolean is
   begin
      return Self.Props.Exists (Name)
        or else Self.Wallet.Exists (Self.Prefix (1 .. Self.Length) & Name);
   end Exists;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Wallet_Manager;
                     Name : in String) is
      Prefixed_Name : constant String := Self.Prefix (1 .. Self.Length) & Name;
   begin
      if Self.Wallet.Exists (Prefixed_Name) then
         Self.Wallet.Remove (Prefixed_Name);
      else
         Self.Props.Remove (Name);
      end if;
   end Remove;

   --  ------------------------------
   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   --  ------------------------------
   procedure Iterate (Self    : in Wallet_Manager;
                      Process : access procedure (Name : in String;
                                                  Item : in Util.Beans.Objects.Object)) is
      procedure Wallet_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object);
      procedure Property_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object);

      procedure Wallet_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object) is
      begin
         if Util.Strings.Starts_With (Name, Self.Prefix (1 .. Self.Length)) then
            Process (Name (Name'First + Self.Length .. Name'Last), Item);
         end if;
      end Wallet_Filter;

      procedure Property_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object) is
         Prefixed_Name : constant String := Self.Prefix (1 .. Self.Length) & Name;
      begin
         if not Self.Wallet.Exists (Prefixed_Name) then
            Process (Name, Item);
         end if;
      end Property_Filter;

   begin
      Self.Props.Iterate (Property_Filter'Access);
      Self.Wallet.Iterate (Wallet_Filter'Access);
   end Iterate;

   --  ------------------------------
   --  Deep copy of properties stored in 'From' to 'To'.
   --  ------------------------------
   function Create_Copy (Self : in Wallet_Manager)
                         return Util.Properties.Implementation.Manager_Access is
      Result : constant Property_Map_Access := new Property_Map;
   begin
      Result.Length := Self.Length;
      Result.Wallet := Self.Wallet;
      Result.Props := Self.Props;
      Result.Prefix := Self.Prefix;
      return Result.all'Access;
   end Create_Copy;

   --  ------------------------------
   --  Merge the configuration content and the keystore to a final configuration object.
   --  The keystore can be used to store sensitive information such as database connection,
   --  secret keys while the rest of the configuration remains in clear property files.
   --  The keystore must be unlocked to have access to its content.
   --  The prefix parameter is used to prefix names from the keystore so that the same
   --  keystore could be used by several applications.
   --  ------------------------------
   procedure Merge (Into   : in out ASF.Applications.Config;
                    Config : in out ASF.Applications.Config;
                    Wallet : in out Keystore.Properties.Manager;
                    Prefix : in String) is
      function Allocate return Util.Properties.Implementation.Shared_Manager_Access;

      function Allocate return Util.Properties.Implementation.Shared_Manager_Access is
         Result : constant Property_Map_Access := new Property_Map;
      begin
         Result.Length := Prefix'Length;
         Result.Wallet := Wallet;
         Result.Props := Config;
         Result.Prefix (1 .. Result.Length) := Prefix;
         return Result.all'Access;
      end Allocate;

      procedure Setup is
        new Util.Properties.Implementation.Initialize (Allocate);

   begin
      Setup (Into);
   end Merge;

   --  ------------------------------
   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   --  ------------------------------
   package body Reader_Config is
      App_Access : constant ASF.Contexts.Faces.Application_Access := App.all'Unchecked_Access;

      package Bean_Config is
        new ASF.Applications.Main.Configs.Reader_Config (Mapper, App_Access,
                                                         Context.all'Access,
                                                         Override_Context);

      package Event_Config is
        new AWA.Events.Configs.Reader_Config (Mapper  => Mapper,
                                              Manager => App.Events'Unchecked_Access,
                                              Context => Context.all'Access);

      pragma Warnings (Off, Bean_Config);
      pragma Warnings (Off, Event_Config);

   begin
      Event_Config.Initialize;
   end Reader_Config;

   --  ------------------------------
   --  Read the application configuration file and configure the application
   --  ------------------------------
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access;
                                 Override_Context : in Boolean) is

      Reader : Util.Serialize.IO.XML.Parser;
      Mapper : Util.Serialize.Mappers.Processing;
      Ctx    : AWA.Services.Contexts.Service_Context;
      Sec    : constant Security.Policies.Policy_Manager_Access := App.Get_Security_Manager;
   begin
      Log.Info ("Reading application configuration file {0}", File);
      Ctx.Set_Context (App'Unchecked_Access, null);

      declare
         package Config is new Reader_Config (Mapper, App'Unchecked_Access, Context,
                                              Override_Context);
         pragma Warnings (Off, Config);
      begin
         Sec.Prepare_Config (Mapper);

         --  Initialize the parser with the module configuration mappers (if any).
         Initialize_Parser (App, Reader);

         if Log.Get_Level >= Util.Log.DEBUG_LEVEL then
            Util.Serialize.Mappers.Dump (Mapper, Log);
         end if;

         --  Read the configuration file and record managed beans, navigation rules.
         Reader.Parse (File, Mapper);
      end;
   exception
      when others =>
         Log.Error ("Error while reading {0}", File);
         raise;
   end Read_Configuration;

   --  ------------------------------
   --  Get the configuration path for the application name.
   --  The configuration path is search from:
   --  o the current directory,
   --  o the 'config' directory,
   --  o the Dynamo installation directory in share/dynamo
   --  ------------------------------
   function Get_Config_Path (Name : in String) return String is
      use Ada.Strings.Unbounded;
      use Ada.Directories;

      Command : constant String := Ada.Command_Line.Command_Name;
      Path    : constant String := Ada.Directories.Containing_Directory (Command);
      Dir     : constant String := Containing_Directory (Path);
      Paths   : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Append (Paths, ".;");
      Append (Paths, Util.Files.Compose (Dir, "config"));
      Append (Paths, ";");
      Append (Paths, Util.Files.Compose (Dir, "share/dynamo/" & Name));
      return Util.Files.Find_File_Path (Name & ".properties", To_String (Paths));
   end Get_Config_Path;

end AWA.Applications.Configs;

-----------------------------------------------------------------------
--  awa-applications-configs -- Read application configuration files
--  Copyright (C) 2011, 2012, 2015, 2017, 2018, 2020 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.Command_Line;
with Ada.Directories;
with Ada.Strings.Unbounded;

with Util.Strings;
with Util.Properties;
with Util.Beans.Objects;
with Util.Files;
with Util.Log.Loggers;
with Util.Serialize.IO.XML;

with ASF.Contexts.Faces;
with ASF.Applications.Main.Configs;

with Security.Policies;
with AWA.Events.Configs.Reader_Config;
with AWA.Services.Contexts;

package body AWA.Applications.Configs is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Applications.Configs");

   type Wallet_Manager is limited new Util.Properties.Implementation.Manager with record
      Wallet : Keystore.Properties.Manager;
      Props  : ASF.Applications.Config;
      Length : Positive;
      Prefix : String (1 .. MAX_PREFIX_LENGTH);
   end record;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   overriding
   function Get_Value (From : in Wallet_Manager;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   overriding
   procedure Set_Value (From  : in out Wallet_Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Returns TRUE if the property exists.
   overriding
   function Exists (Self : in Wallet_Manager;
                    Name : in String)
                    return Boolean;

   --  Remove the property given its name.
   overriding
   procedure Remove (Self : in out Wallet_Manager;
                     Name : in String);

   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   overriding
   procedure Iterate (Self    : in Wallet_Manager;
                      Process : access procedure (Name : in String;
                                                  Item : in Util.Beans.Objects.Object));

   --  Deep copy of properties stored in 'From' to 'To'.
   function Create_Copy (Self : in Wallet_Manager)
                         return Util.Properties.Implementation.Manager_Access;

   package Shared_Manager is
     new Util.Properties.Implementation.Shared_Implementation (Wallet_Manager);

   subtype Property_Map is Shared_Manager.Manager;
   type Property_Map_Access is access all Property_Map;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   overriding
   function Get_Value (From : in Wallet_Manager;
                       Name : in String) return Util.Beans.Objects.Object is
      Prefixed_Name : constant String := From.Prefix (1 .. From.Length) & Name;
   begin
      if From.Wallet.Exists (Prefixed_Name) then
         declare
            Value : constant String := From.Wallet.Get (Prefixed_Name);
         begin
            return Util.Beans.Objects.To_Object (Value);
         end;
      else
         return From.Props.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Wallet_Manager;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
      Prefixed_Name : constant String := From.Prefix (1 .. From.Length) & Name;
   begin
      if From.Wallet.Exists (Prefixed_Name) then
         From.Wallet.Set_Value (Prefixed_Name, Value);
      else
         From.Props.Set_Value (Name, Value);
      end if;
   end Set_Value;

   --  ------------------------------
   --  Returns TRUE if the property exists.
   --  ------------------------------
   function Exists (Self : in Wallet_Manager;
                    Name : in String)
                    return Boolean is
   begin
      return Self.Props.Exists (Name)
        or else Self.Wallet.Exists (Self.Prefix (1 .. Self.Length) & Name);
   end Exists;

   --  ------------------------------
   --  Remove the property given its name.
   --  ------------------------------
   procedure Remove (Self : in out Wallet_Manager;
                     Name : in String) is
      Prefixed_Name : constant String := Self.Prefix (1 .. Self.Length) & Name;
   begin
      if Self.Wallet.Exists (Prefixed_Name) then
         Self.Wallet.Remove (Prefixed_Name);
      else
         Self.Props.Remove (Name);
      end if;
   end Remove;

   --  ------------------------------
   --  Iterate over the properties and execute the given procedure passing the
   --  property name and its value.
   --  ------------------------------
   procedure Iterate (Self    : in Wallet_Manager;
                      Process : access procedure (Name : in String;
                                                  Item : in Util.Beans.Objects.Object)) is
      procedure Wallet_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object);
      procedure Property_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object);

      procedure Wallet_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object) is
      begin
         if Util.Strings.Starts_With (Name, Self.Prefix (1 .. Self.Length)) then
            Log.Debug ("Use wallet property {0} as {1}",
                       Name, Name (Name'First + Self.Length .. Name'Last));
            Process (Name (Name'First + Self.Length .. Name'Last), Item);
         end if;
      end Wallet_Filter;

      procedure Property_Filter (Name : in String;
                               Item : in Util.Beans.Objects.Object) is
         Prefixed_Name : constant String := Self.Prefix (1 .. Self.Length) & Name;
      begin
         if not Self.Wallet.Exists (Prefixed_Name) then
            Process (Name, Item);
         end if;
      end Property_Filter;

   begin
      Self.Props.Iterate (Property_Filter'Access);
      Self.Wallet.Iterate (Wallet_Filter'Access);
   end Iterate;

   --  ------------------------------
   --  Deep copy of properties stored in 'From' to 'To'.
   --  ------------------------------
   function Create_Copy (Self : in Wallet_Manager)
                         return Util.Properties.Implementation.Manager_Access is
      Result : constant Property_Map_Access := new Property_Map;
   begin
      Result.Length := Self.Length;
      Result.Wallet := Self.Wallet;
      Result.Props := Self.Props;
      Result.Prefix := Self.Prefix;
      return Result.all'Access;
   end Create_Copy;

   --  ------------------------------
   --  Merge the configuration content and the keystore to a final configuration object.
   --  The keystore can be used to store sensitive information such as database connection,
   --  secret keys while the rest of the configuration remains in clear property files.
   --  The keystore must be unlocked to have access to its content.
   --  The prefix parameter is used to prefix names from the keystore so that the same
   --  keystore could be used by several applications.
   --  ------------------------------
   procedure Merge (Into   : in out ASF.Applications.Config;
                    Config : in out ASF.Applications.Config;
                    Wallet : in out Keystore.Properties.Manager;
                    Prefix : in String) is
      function Allocate return Util.Properties.Implementation.Shared_Manager_Access;

      function Allocate return Util.Properties.Implementation.Shared_Manager_Access is
         Result : constant Property_Map_Access := new Property_Map;
      begin
         Result.Length := Prefix'Length;
         Result.Wallet := Wallet;
         Result.Props := Config;
         Result.Prefix (1 .. Result.Length) := Prefix;
         return Result.all'Access;
      end Allocate;

      procedure Setup is
        new Util.Properties.Implementation.Initialize (Allocate);

   begin
      Setup (Into);
   end Merge;

   --  ------------------------------
   --  XML reader configuration.  By instantiating this generic package, the XML parser
   --  gets initialized to read the configuration for servlets, filters, managed beans,
   --  permissions, events and other configuration elements.
   --  ------------------------------
   package body Reader_Config is
      App_Access : constant ASF.Contexts.Faces.Application_Access := App.all'Unchecked_Access;

      package Bean_Config is
        new ASF.Applications.Main.Configs.Reader_Config (Mapper, App_Access,
                                                         Context.all'Access,
                                                         Override_Context);

      package Event_Config is
        new AWA.Events.Configs.Reader_Config (Mapper  => Mapper,
                                              Manager => App.Events'Unchecked_Access,
                                              Context => Context.all'Access);

      pragma Warnings (Off, Bean_Config);
      pragma Warnings (Off, Event_Config);

   begin
      Event_Config.Initialize;
   end Reader_Config;

   --  ------------------------------
   --  Read the application configuration file and configure the application
   --  ------------------------------
   procedure Read_Configuration (App     : in out Application'Class;
                                 File    : in String;
                                 Context : in EL.Contexts.Default.Default_Context_Access;
                                 Override_Context : in Boolean) is

      Reader : Util.Serialize.IO.XML.Parser;
      Mapper : Util.Serialize.Mappers.Processing;
      Ctx    : AWA.Services.Contexts.Service_Context;
      Sec    : constant Security.Policies.Policy_Manager_Access := App.Get_Security_Manager;
   begin
      Log.Info ("Reading application configuration file {0}", File);
      Ctx.Set_Context (App'Unchecked_Access, null);

      declare
         package Config is new Reader_Config (Mapper, App'Unchecked_Access, Context,
                                              Override_Context);
         pragma Warnings (Off, Config);
      begin
         Sec.Prepare_Config (Mapper);

         --  Initialize the parser with the module configuration mappers (if any).
         Initialize_Parser (App, Reader);

         if Log.Get_Level >= Util.Log.DEBUG_LEVEL then
            Util.Serialize.Mappers.Dump (Mapper, Log);
         end if;

         --  Read the configuration file and record managed beans, navigation rules.
         Reader.Parse (File, Mapper);
      end;
   exception
      when others =>
         Log.Error ("Error while reading {0}", File);
         raise;
   end Read_Configuration;

   --  ------------------------------
   --  Get the configuration path for the application name.
   --  The configuration path is search from:
   --  o the current directory,
   --  o the 'config' directory,
   --  o the Dynamo installation directory in share/dynamo
   --  ------------------------------
   function Get_Config_Path (Name : in String) return String is
      use Ada.Strings.Unbounded;
      use Ada.Directories;

      Command : constant String := Ada.Command_Line.Command_Name;
      Path    : constant String := Ada.Directories.Containing_Directory (Command);
      Dir     : constant String := Containing_Directory (Path);
      Paths   : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Append (Paths, ".;");
      Append (Paths, Util.Files.Compose (Dir, "config"));
      Append (Paths, ";");
      Append (Paths, Util.Files.Compose (Dir, "share/dynamo/" & Name));
      return Util.Files.Find_File_Path (Name & ".properties", To_String (Paths));
   end Get_Config_Path;

end AWA.Applications.Configs;

Add some debugging trace

Add some debugging trace


-----------------------------------------------------------------------
--  html-factory -- Factory for HTML UI Components
--  Copyright (C) 2009, 2010 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.Components.Html.Text;
with ASF.Components.Html.Lists;
with ASF.Views.Nodes;
package body ASF.Components.Html.Factory is

   function Create_Output return UIComponent_Access;
   function Create_Label return UIComponent_Access;
   function Create_List return UIComponent_Access;

   --  ------------------------------
   --  Create an UIOutput component
   --  ------------------------------
   function Create_Output return UIComponent_Access is
   begin
      return new ASF.Components.Html.Text.UIOutput;
   end Create_Output;

   --  ------------------------------
   --  Create a label component
   --  ------------------------------
   function Create_Label return UIComponent_Access is
   begin
      return new ASF.Components.Html.Text.UILabel;
   end Create_Label;

   --  ------------------------------
   --  Create an UIList component
   --  ------------------------------
   function Create_List return UIComponent_Access is
   begin
      return new ASF.Components.Html.Lists.UIList;
   end Create_List;

   use ASF.Views.Nodes;

   URI        : aliased constant String := "http://java.sun.com/jsf/html";
   OUTPUT_TAG : aliased constant String := "output";
   LABEL_TAG  : aliased constant String := "label";
   LIST_TAG   : aliased constant String := "list";

   Html_Bindings : aliased constant ASF.Factory.Binding_Array
     := (2 => (Name      => OUTPUT_TAG'Access,
               Component => Create_Output'Access,
               Tag       => Create_Component_Node'Access),
         0 => (Name      => LABEL_TAG'Access,
               Component => Create_Label'Access,
               Tag       => Create_Component_Node'Access),
         1 => (Name      => LIST_TAG'Access,
               Component => Create_List'Access,
               Tag       => Create_Component_Node'Access)
        );

   Html_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Html_Bindings'Access);

   --  ------------------------------
   --  Get the HTML component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Html_Factory'Access;
   end Definition;

begin
   ASF.Factory.Check (Html_Factory);
end ASF.Components.Html.Factory;

-----------------------------------------------------------------------
--  html-factory -- Factory for HTML UI Components
--  Copyright (C) 2009, 2010 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.Components.Html.Text;
with ASF.Components.Html.Lists;
with ASF.Components.Html.Links;
with ASF.Views.Nodes;
package body ASF.Components.Html.Factory is

   function Create_Output return UIComponent_Access;
   function Create_Output_Link return UIComponent_Access;
   function Create_Label return UIComponent_Access;
   function Create_List return UIComponent_Access;

   --  ------------------------------
   --  Create an UIOutput component
   --  ------------------------------
   function Create_Output return UIComponent_Access is
   begin
      return new ASF.Components.Html.Text.UIOutput;
   end Create_Output;

   --  ------------------------------
   --  Create an UIOutputLink component
   --  ------------------------------
   function Create_Output_Link return UIComponent_Access is
   begin
      return new ASF.Components.Html.Links.UIOutputLink;
   end Create_Output_Link;

   --  ------------------------------
   --  Create a label component
   --  ------------------------------
   function Create_Label return UIComponent_Access is
   begin
      return new ASF.Components.Html.Text.UILabel;
   end Create_Label;

   --  ------------------------------
   --  Create an UIList component
   --  ------------------------------
   function Create_List return UIComponent_Access is
   begin
      return new ASF.Components.Html.Lists.UIList;
   end Create_List;

   use ASF.Views.Nodes;

   URI        : aliased constant String := "http://java.sun.com/jsf/html";
   OUTPUT_TEXT_TAG : aliased constant String := "outputText";
   OUTPUT_LINK_TAG : aliased constant String := "outputLink";
   LABEL_TAG       : aliased constant String := "label";
   LIST_TAG        : aliased constant String := "list";

   Html_Bindings : aliased constant ASF.Factory.Binding_Array
     := (4 => (Name      => OUTPUT_TEXT_TAG'Access,
               Component => Create_Output'Access,
               Tag       => Create_Component_Node'Access),
         1 => (Name      => LABEL_TAG'Access,
               Component => Create_Label'Access,
               Tag       => Create_Component_Node'Access),
         2 => (Name      => LIST_TAG'Access,
               Component => Create_List'Access,
               Tag       => Create_Component_Node'Access),
         3 => (Name      => OUTPUT_LINK_TAG'Access,
               Component => Create_Output_Link'Access,
               Tag       => Create_Component_Node'Access)
        );

   Html_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Html_Bindings'Access);

   --  ------------------------------
   --  Get the HTML component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Html_Factory'Access;
   end Definition;

begin
   ASF.Factory.Check (Html_Factory);
end ASF.Components.Html.Factory;

Update the jsf components factory

Update the jsf components factory


-----------------------------------------------------------------------
--  gen-commands-project -- Project creation command for dynamo
--  Copyright (C) 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 Ada.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with GNAT.OS_Lib;

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  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;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Gen.Commands.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Gen.Commands.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   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 ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|proprietary] [-web] [-tool] [-ado] "
                & "NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the GNU license or");
      Put_Line ("  a proprietary license. The author's name and email addresses");
      Put_Line ("  are also reported in generated files.");
      New_Line;
      Put_Line ("  -web   Generate a Web application");
      Put_Line ("  -tool  Generate a command line tool");
      Put_Line ("  -ado   Generate a database tool operation for ADO");
   end Help;

end Gen.Commands.Project;

-----------------------------------------------------------------------
--  gen-commands-project -- Project creation command for dynamo
--  Copyright (C) 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 Ada.Directories;
with Ada.Text_IO;
with Gen.Artifacts;
with GNAT.Command_Line;
with GNAT.OS_Lib;

with Util.Log.Loggers;
with Util.Strings.Transforms;
package body Gen.Commands.Project is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("Gen.Commands.Project");

   --  ------------------------------
   --  Generator Command
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String;

   --  ------------------------------
   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   --  ------------------------------
   function Get_Name_From_Email (Email : in String) return String is
      Pos : Natural := Util.Strings.Index (Email, '<');
   begin
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      end if;
      Pos := Util.Strings.Index (Email, '@');
      if Pos > 0 then
         return Email (Email'First .. Pos - 1);
      else
         return Email;
      end if;
   end Get_Name_From_Email;

   --  ------------------------------
   --  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;

      Web_Flag  : aliased Boolean := False;
      Tool_Flag : aliased Boolean := False;
      Ado_Flag  : aliased Boolean := False;
   begin
      --  If a dynamo.xml file exists, read it.
      if Ada.Directories.Exists ("dynamo.xml") then
         Generator.Read_Project ("dynamo.xml");
      else
         Generator.Set_Project_Property ("license", "apache");
         Generator.Set_Project_Property ("author", "unknown");
         Generator.Set_Project_Property ("author_email", "unknown@company.com");
      end if;
      --  Parse the command line
      loop
         case Getopt ("l: ? -web -tool -ado") is
         when ASCII.NUL => exit;

         when '-' =>
            if Full_Switch = "-web" then
               Web_Flag := True;
            elsif Full_Switch = "-tool" then
               Tool_Flag := True;
            elsif Full_Switch = "-ado" then
               Ado_Flag := True;
            end if;

         when 'l' =>
            declare
               L : constant String := Util.Strings.Transforms.To_Lower_Case (Parameter);
            begin
               Log.Info ("License {0}", L);

               if L = "apache" then
                  Generator.Set_Project_Property ("license", "apache");
               elsif L = "gpl" then
                  Generator.Set_Project_Property ("license", "gpl");
               elsif L = "proprietary" then
                  Generator.Set_Project_Property ("license", "proprietary");
               else
                  Generator.Error ("Invalid license: {0}", L);
                  Generator.Error ("Valid licenses: apache, gpl, proprietary");
                  return;
               end if;
            end;

         when others =>
            null;
         end case;
      end loop;
      if not Web_Flag and not Ado_Flag and not Tool_Flag then
         Web_Flag := True;
      end if;
      declare
         Name  : constant String := Get_Argument;
         Arg2  : constant String := Get_Argument;
         Arg3  : constant String := Get_Argument;
      begin
         if Name'Length = 0 then
            Generator.Error ("Missing project name");
            Gen.Commands.Usage;
            return;
         end if;

         if Util.Strings.Index (Arg2, '@') > Arg2'First then
            Generator.Set_Project_Property ("author_email", Arg2);
            if Arg3'Length = 0 then
               Generator.Set_Project_Property ("author", Get_Name_From_Email (Arg2));
            else
               Generator.Set_Project_Property ("author", Arg3);
            end if;

         elsif Util.Strings.Index (Arg3, '@') > Arg3'First then
            Generator.Set_Project_Property ("author", Arg2);
            Generator.Set_Project_Property ("author_email", Arg3);

         elsif Arg3'Length > 0 then
            Generator.Error ("The last argument should be the author's email address.");
            Gen.Commands.Usage;
            return;
         end if;

         Generator.Set_Project_Property ("is_web", Boolean'Image (Web_Flag));
         Generator.Set_Project_Property ("is_tool", Boolean'Image (Tool_Flag));
         Generator.Set_Project_Property ("is_ado", Boolean'Image (Ado_Flag));
         Generator.Set_Project_Name (Name);
         Generator.Set_Force_Save (False);
         if Ado_Flag then
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project-ado");
         else
            Gen.Generator.Generate_All (Generator, Gen.Artifacts.ITERATION_TABLE, "project");
         end if;

         Generator.Save_Project;
         declare
            use type GNAT.OS_Lib.String_Access;

            Path   : constant GNAT.OS_Lib.String_Access
              := GNAT.OS_Lib.Locate_Exec_On_Path ("autoconf");
            Args   : GNAT.OS_Lib.Argument_List (1 .. 0);
            Status : Boolean;
         begin
            if Path = null then
               Generator.Error ("The 'autoconf' tool was not found.  It is necessary to "
                                & "generate the configure script.");
               Generator.Error ("Install 'autoconf' or launch it manually.");
            else
               Ada.Directories.Set_Directory (Generator.Get_Result_Directory);
               Log.Info ("Executing {0}", Path.all);
               GNAT.OS_Lib.Spawn (Path.all, Args, Status);
               if not Status then
                  Generator.Error ("Execution of {0} failed", Path.all);
               end if;
            end if;
         end;
      end;
   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 ("create-project: Create a new Ada Web Application project");
      Put_Line ("Usage: create-project [-l apache|gpl|proprietary] [--web] [--tool] [--ado] "
                & "NAME [AUTHOR] [EMAIL]");
      New_Line;
      Put_Line ("  Creates a new AWA application with the name passed in NAME.");
      Put_Line ("  The application license is controlled with the -l option. ");
      Put_Line ("  License headers can use either the Apache, the GNU license or");
      Put_Line ("  a proprietary license. The author's name and email addresses");
      Put_Line ("  are also reported in generated files.");
      New_Line;
      Put_Line ("  --web   Generate a Web application (the default)");
      Put_Line ("  --tool  Generate a command line tool");
      Put_Line ("  --ado   Generate a database tool operation for ADO");
   end Help;

end Gen.Commands.Project;

Update the create-project help message

Update the create-project help message


--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
        Trim (Get_Message (Info), Ada.Strings.Both));
      Put (File, ">");
      Put_Line (File, Get_Message (Info));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

--
-- Copyright (c) 2007-2009 Tero Koskinen <tero.koskinen@iki.fi>
--
-- Permission to use, copy, modify, and distribute this software for any
-- purpose with or without fee is hereby granted, provided that the above
-- copyright notice and this permission notice appear in all copies.
--
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
--

with Ada.Text_IO;
with Ada.Strings;
with Ada.Strings.Fixed;
with Ada.Strings.Maps;

with Ahven.Runner;

with Ahven_Compat;
with Ahven.AStrings;

package body Ahven.XML_Runner is
   use Ada.Text_IO;
   use Ada.Strings.Fixed;
   use Ada.Strings.Maps;

   use Ahven.Results;
   use Ahven.Framework;
   use Ahven.AStrings;

   function Filter_String (Str : String) return String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info);
   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info);
   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info);

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String);

   procedure Print_Log_File (File : File_Type; Filename : String);

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String);

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String);

   procedure End_Testcase_Tag (File : File_Type);

   function Create_Name (Dir : String; Name : String) return String;

   function Filter_String (Str : String) return String is
      Result : String (Str'First .. Str'First + 6 * Str'Length);
      Pos    : Natural := Str'First;
   begin
      for I in Str'Range loop
         if Str (I) = ''' then
            Result (Pos .. Pos + 6 - 1) := "'";
            Pos := Pos + 6;
         elsif Str (I) = '<' then
            Result (Pos .. Pos + 4 - 1) := "<";
            Pos := Pos + 4;
         elsif Str (I) = '>' then
            Result (Pos .. Pos + 4 - 1) := ">";
            Pos := Pos + 4;
         elsif Str (I) = '&' then
            Result (Pos .. Pos + 5 - 1) := "&";
            Pos := Pos + 5;
         elsif Str (I) = '"' then
            Result (Pos) := ''';
            Pos := Pos + 1;
         else
            Result (Pos) := Str (I);
            Pos := Pos + 1;
         end if;
      end loop;

      return Result (Result'First .. Pos - 1);
   end Filter_String;

   function Filter_String
     (Str : String;
      Map : Character_Mapping)
      return String
   is
   begin
      return Translate (Source  => Str,
                        Mapping => Map);
   end Filter_String;

   procedure Print_Attribute (File : File_Type; Attr : String;
                              Value : String) is
   begin
      Put (File, Attr & "=" & '"' & Value & '"');
   end Print_Attribute;

   procedure Start_Testcase_Tag (File : File_Type;
                                 Parent : String; Name : String;
                                 Execution_Time : String) is
   begin
      Put (File, "<testcase ");
      Print_Attribute (File, "classname", Filter_String (Parent));
      Put (File, " ");
      Print_Attribute (File, "name", Filter_String (Name));
      Put (File, " ");
      Print_Attribute (File, "time", Filter_String (Execution_Time));
      Put_Line (File, ">");
   end Start_Testcase_Tag;

   procedure End_Testcase_Tag (File : File_Type) is
   begin
      Put_Line (File, "</testcase>");
   end End_Testcase_Tag;

   function Create_Name (Dir : String; Name : String) return String
   is
      function Filename (Test : String) return String is
         Map : Ada.Strings.Maps.Character_Mapping;
      begin
         Map := To_Mapping (From => " '/\<>:|?*()" & '"',
                            To   => "-___________" & '_');

         return "TEST-" & Filter_String (Test, Map) & ".xml";
      end Filename;
   begin
      if Dir'Length > 0 then
         return Dir & Ahven_Compat.Directory_Separator & Filename (Name);
      else
         return Filename (Name);
      end if;
   end Create_Name;

   procedure Print_Test_Pass (File : File_Type;
                              Parent_Test : String;
                              Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Pass;

   procedure Print_Test_Skipped (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<skipped ");

      Print_Attribute (File, "message",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</skipped>");
      End_Testcase_Tag (File);
   end Print_Test_Skipped;

   procedure Print_Test_Failure (File : File_Type;
                                 Parent_Test : String;
                                 Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<failure ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</failure>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Failure;

   procedure Print_Test_Error (File : File_Type;
                               Parent_Test : String;
                               Info : Result_Info) is
      Exec_Time : constant String :=
        Trim (Duration'Image (Get_Execution_Time (Info)), Ada.Strings.Both);
   begin
      Start_Testcase_Tag
        (File           => File,
         Parent         => Parent_Test,
         Name           => Get_Routine_Name (Info),
         Execution_Time => Exec_Time);

      Put (File, "<error ");
      Print_Attribute (File, "type",
                       Filter_String (Trim (Get_Message (Info), Ada.Strings.Both)));
      Put (File, ">");
      Put_Line (File, Filter_String (Get_Message (Info)));
      Put_Line (File, "</error>");
      if Length (Get_Output_File (Info)) > 0 then
         Put (File, "<system-out>");
         Print_Log_File (File, To_String (Get_Output_File (Info)));
         Put_Line (File, "</system-out>");
      end if;
      End_Testcase_Tag (File);
   end Print_Test_Error;

   procedure Print_Test_Case (Collection : Result_Collection;
                              Dir : String) is
      procedure Print (Output : File_Type;
                       Result : Result_Collection);
      -- Internal procedure to print the testcase into given file.

      function Img (Value : Natural) return String is
      begin
         return Trim (Natural'Image (Value), Ada.Strings.Both);
      end Img;

      procedure Print (Output : File_Type;
                       Result : Result_Collection) is
         Position : Result_Info_Cursor;
      begin
         Put_Line (Output, "<?xml version=" & '"' & "1.0" & '"' &
                   " encoding=" & '"' & "iso-8859-1" & '"' &
                   "?>");
         Put (Output, "<testsuite ");
         Print_Attribute (Output, "errors", Img (Error_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "failures", Img (Failure_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "skips", Img (Skipped_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "tests", Img (Test_Count (Result)));
         Put (Output, " ");
         Print_Attribute (Output, "time",
           Trim (Duration'Image (Get_Execution_Time (Result)),
                 Ada.Strings.Both));
         Put (Output, " ");
         Print_Attribute (Output,
           "name", To_String (Get_Test_Name (Result)));
         Put_Line (Output, ">");

         Position := First_Error (Result);
         Error_Loop:
         loop
            exit Error_Loop when not Is_Valid (Position);
            Print_Test_Error (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Error_Loop;

         Position := First_Failure (Result);
         Failure_Loop:
         loop
            exit Failure_Loop when not Is_Valid (Position);
            Print_Test_Failure (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Failure_Loop;

         Position := First_Pass (Result);
         Pass_Loop:
         loop
            exit Pass_Loop when not Is_Valid (Position);
            Print_Test_Pass (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Pass_Loop;

         Position := First_Skipped (Result);
         Skip_Loop:
         loop
            exit Skip_Loop when not Is_Valid (Position);

            Print_Test_Skipped (Output,
              To_String (Get_Test_Name (Result)), Data (Position));
            Position := Next (Position);
         end loop Skip_Loop;

         Put_Line (Output, "</testsuite>");
      end Print;

      File : File_Type;
   begin
      if Dir = "-" then
         Print (Standard_Output, Collection);
      else
         Create (File => File, Mode => Ada.Text_IO.Out_File,
           Name => Create_Name (Dir, To_String (Get_Test_Name (Collection))));
         Print (File, Collection);
         Ada.Text_IO.Close (File);
      end if;
   end Print_Test_Case;

   procedure Report_Results (Result : Result_Collection;
                             Dir    : String) is
      Position : Result_Collection_Cursor;
   begin
      Position := First_Child (Result);
      loop
         exit when not Is_Valid (Position);
         if Child_Depth (Data (Position).all) = 0 then
            Print_Test_Case (Data (Position).all, Dir);
         else
            Report_Results (Data (Position).all, Dir);

            -- Handle the test cases in this collection
            if Direct_Test_Count (Result) > 0 then
               Print_Test_Case (Result, Dir);
            end if;
         end if;
         Position := Next (Position);
      end loop;
   end Report_Results;

   -- Print the log by placing the data inside CDATA block.
   procedure Print_Log_File (File : File_Type; Filename : String) is
      type CData_End_State is (NONE, FIRST_BRACKET, SECOND_BRACKET);

      function State_Change (Old_State : CData_End_State)
        return CData_End_State;

      Handle : File_Type;
      Char   : Character := ' ';
      First  : Boolean := True;

      -- We need to escape ]]>, this variable tracks
      -- the characters, so we know when to do the escaping.
      CData_Ending : CData_End_State := NONE;

      function State_Change (Old_State : CData_End_State)
        return CData_End_State
      is
         New_State : CData_End_State := NONE;
         -- By default New_State will be NONE, so there is
         -- no need to set it inside when blocks.
      begin
         case Old_State is
            when NONE =>
               if Char = ']' then
                  New_State := FIRST_BRACKET;
               end if;
            when FIRST_BRACKET =>
               if Char = ']' then
                  New_State := SECOND_BRACKET;
               end if;
            when SECOND_BRACKET =>
               if Char = '>' then
                  Put (File, " ");
               end if;
         end case;
         return New_State;
      end State_Change;
   begin
      Open (Handle, In_File, Filename);
      loop
         exit when End_Of_File (Handle);
         Get (Handle, Char);
         if First then
            Put (File, "<![CDATA[");
            First := False;
         end if;
         CData_Ending := State_Change (CData_Ending);

         Put (File, Char);
         if End_Of_Line (Handle) then
            New_Line (File);
         end if;
      end loop;

      Close (Handle);
      if not First then
         Put_Line (File, "]]>");
      end if;
   end Print_Log_File;

   procedure Do_Report (Test_Results : Results.Result_Collection;
                        Args         : Parameters.Parameter_Info) is
   begin
      Report_Results (Test_Results,
                      Parameters.Result_Dir (Args));
   end Do_Report;

   procedure Run (Suite : in out Framework.Test_Suite'Class) is
   begin
      Runner.Run_Suite (Suite, Do_Report'Access);
   end Run;

   procedure Run (Suite : Framework.Test_Suite_Access) is
   begin
      Run (Suite.all);
   end Run;
end Ahven.XML_Runner;

Fix other issues when a message contains unclosed XML entities.


-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  Copyright (C) 2009, 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.Tests;
with Util.Test_Caller;

with ASF.Tests;
with AWA.Tests;
with AWA.Users.Models;
with AWA.Users.Services.Tests.Helpers;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
	  Email   : constant String := "Joe-" & Util.Tests.Get_UUID & "@gmail.com";
      Principal : Services.Tests.Helpers.Test_User;
   begin
      Services.Tests.Helpers.Initialize (Principal);

      Do_Get (Request, Reply, "/users/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("first_name", "joe");
      Request.Set_Parameter ("last_name", "dalton");
      Request.Set_Parameter ("register", "1");
      Do_Post (Request, Reply, "/users/register.html", "create-user-2.html");

      Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      Assert (T, Request.Get_User_Principal = null, "A user principal should not be defined");

	  --  Now, get the access key and simulate a click on the validation link.
	  declare

		 Key       : AWA.Users.Models.Access_Key_Ref;
      begin
	     Services.Tests.Helpers.Find_Access_Key (Principal, Email, Key);
		 Assert (T, not Key.Is_Null, "There is no access key associated with the user");
		 Request.Set_Parameter ("key", Key.Get_Access_Key);
		 Do_Get (Request, Reply, "/users/validate.html", "validate-user-1.html");
	  end;

      --  Check that the user is logged and we have a user principal now.
      Assert (T, Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

   procedure Test_Logout_User (T : in out Test) is
   begin
      null;
   end Test_Logout_User;

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Do_Get (Request, Reply, "/users/login.html", "login-user-1.html");

      --  Check that the user is NOT logged.
      Assert (T, Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("login", "1");
      Do_Post (Request, Reply, "/users/login.html", "login-user-2.html");

      Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      Assert (T, Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Email   : constant String := "Joe@gmail.com";
   begin
      Do_Get (Request, Reply, "/users/lost-password.html", "lost-password-1.html");

      Request.Set_Parameter ("email", Email);
      Do_Post (Request, Reply, "/users/lost-password.html", "lost-password-2.html");

      Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

	  --  Now, get the access key and simulate a click on the reset password link.
	  declare
         Principal : Services.Tests.Helpers.Test_User;
		 Key       : AWA.Users.Models.Access_Key_Ref;
      begin
	     Services.Tests.Helpers.Find_Access_Key (Principal, Email, Key);
		 Assert (T, not Key.Is_Null, "There is no access key associated with the user");
		 Request.Set_Parameter ("key", Key.Get_Access_Key);
		 Do_Get (Request, Reply, "/users/reset-password.html", "reset-password-1.html");

		 --  Post the reset password
		 Request.Set_Parameter ("password", "asd");
		 Request.Set_Parameter ("reset-password", "1");
		 Do_Post (Request, Reply, "/users/reset-password.html", "reset-password-2.html");

         Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         Assert (T, Request.Get_User_Principal /= null, "A user principal should be defined");
	 end;
  end Test_Reset_Password_User;

end AWA.Users.Tests;

-----------------------------------------------------------------------
--  files.tests -- Unit tests for files
--  Copyright (C) 2009, 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.Tests;
with Util.Test_Caller;

with ASF.Tests;
with AWA.Tests;
with AWA.Users.Models;
with AWA.Users.Services.Tests.Helpers;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
	  Email   : constant String := "Joe-" & Util.Tests.Get_UUID & "@gmail.com";
      Principal : Services.Tests.Helpers.Test_User;
   begin
      Services.Tests.Helpers.Initialize (Principal);

      Do_Get (Request, Reply, "/users/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("first_name", "joe");
      Request.Set_Parameter ("last_name", "dalton");
      Request.Set_Parameter ("register", "1");
      Do_Post (Request, Reply, "/users/register.html", "create-user-2.html");

      Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      Assert (T, Request.Get_User_Principal = null, "A user principal should not be defined");

	  --  Now, get the access key and simulate a click on the validation link.
	  declare

		 Key       : AWA.Users.Models.Access_Key_Ref;
      begin
	     Services.Tests.Helpers.Find_Access_Key (Principal, Email, Key);
		 Assert (T, not Key.Is_Null, "There is no access key associated with the user");
		 Request.Set_Parameter ("key", Key.Get_Access_Key);
		 Do_Get (Request, Reply, "/users/validate.html", "validate-user-1.html");
	  end;

      --  Check that the user is logged and we have a user principal now.
      Assert (T, Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

   procedure Test_Logout_User (T : in out Test) is
   begin
      null;
   end Test_Logout_User;

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
   begin
      Do_Get (Request, Reply, "/users/login.html", "login-user-1.html");

      --  Check that the user is NOT logged.
      Assert (T, Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("login", "1");
      Do_Post (Request, Reply, "/users/login.html", "login-user-2.html");

      Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      Assert (T, Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Email   : constant String := "Joe@gmail.com";
      Principal : Services.Tests.Helpers.Test_User;
   begin
      Services.Tests.Helpers.Initialize (Principal);
      Do_Get (Request, Reply, "/users/lost-password.html", "lost-password-1.html");

      Request.Set_Parameter ("email", Email);
      Do_Post (Request, Reply, "/users/lost-password.html", "lost-password-2.html");

      Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

	  --  Now, get the access key and simulate a click on the reset password link.
	  declare
		 Key       : AWA.Users.Models.Access_Key_Ref;
      begin
	     Services.Tests.Helpers.Find_Access_Key (Principal, Email, Key);
		 Assert (T, not Key.Is_Null, "There is no access key associated with the user");
		 Request.Set_Parameter ("key", Key.Get_Access_Key);
		 Do_Get (Request, Reply, "/users/reset-password.html", "reset-password-1.html");

		 --  Post the reset password
		 Request.Set_Parameter ("password", "asd");
		 Request.Set_Parameter ("reset-password", "1");
		 Do_Post (Request, Reply, "/users/reset-password.html", "reset-password-2.html");

         Assert (T, Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         Assert (T, Request.Get_User_Principal /= null, "A user principal should be defined");
	 end;
  end Test_Reset_Password_User;

end AWA.Users.Tests;

Update lost password unit test

Update lost password unit test


-----------------------------------------------------------------------
--  awa-users-principals -- User principals
--  Copyright (C) 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.
-----------------------------------------------------------------------

package body AWA.Users.Principals is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Name;

   --  ------------------------------
   --  Returns true if the given role is stored in the user principal.
   --  ------------------------------
--     function Has_Role (User : in Principal;
--                        Role : in Security.Permissions.Role_Type) return Boolean is
--     begin
--        return User.Roles (Role);
--     end Has_Role;

   --  ------------------------------
   --  Get the principal identifier (name)
   --  ------------------------------
   function Get_Id (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Id;

   --  ------------------------------
   --  Get the user associated with the principal.
   --  ------------------------------
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref is
   begin
      return From.User;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.User.Get_Id;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the connection session used by the user.
   --  ------------------------------
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref is
   begin
      return From.Session;
   end Get_Session;

   --  ------------------------------
   --  Get the connection session identifier used by the user.
   --  ------------------------------
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.Session.Get_Id;
   end Get_Session_Identifier;

   --  ------------------------------
   --  Create a principal for the given user.
   --  ------------------------------
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access is
      Result : constant Principal_Access := new Principal;
   begin
      Result.User    := User;
	  Result.Session := Session;
      return Result;
   end Create;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   --  ------------------------------
   function Get_User_Identifier (From : in ASF.Principals.Principal_Access)
                                 return ADO.Identifier is
      use type ASF.Principals.Principal_Access;
   begin
      if From = null then
         return ADO.NO_IDENTIFIER;

      elsif not (From.all in Principal'Class) then
         return ADO.NO_IDENTIFIER;

      else
         return Principal'Class (From.all).Get_User_Identifier;
      end if;
   end Get_User_Identifier;

end AWA.Users.Principals;

-----------------------------------------------------------------------
--  awa-users-principals -- User principals
--  Copyright (C) 2011, 2012, 2013 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.
-----------------------------------------------------------------------

package body AWA.Users.Principals is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Name;

   --  ------------------------------
   --  Get the principal identifier (name)
   --  ------------------------------
   function Get_Id (From : in Principal) return String is
   begin
      return From.User.Get_Name;
   end Get_Id;

   --  ------------------------------
   --  Get the user associated with the principal.
   --  ------------------------------
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref is
   begin
      return From.User;
   end Get_User;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   --  ------------------------------
   function Get_User_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.User.Get_Id;
   end Get_User_Identifier;

   --  ------------------------------
   --  Get the connection session used by the user.
   --  ------------------------------
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref is
   begin
      return From.Session;
   end Get_Session;

   --  ------------------------------
   --  Get the connection session identifier used by the user.
   --  ------------------------------
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier is
   begin
      return From.Session.Get_Id;
   end Get_Session_Identifier;

   --  ------------------------------
   --  Create a principal for the given user.
   --  ------------------------------
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access is
      Result : constant Principal_Access := new Principal;
   begin
      Result.User    := User;
      Result.Session := Session;
      return Result;
   end Create;

   --  ------------------------------
   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   --  ------------------------------
   function Get_User_Identifier (From : in ASF.Principals.Principal_Access)
                                 return ADO.Identifier is
      use type ASF.Principals.Principal_Access;
   begin
      if From = null then
         return ADO.NO_IDENTIFIER;

      elsif not (From.all in Principal'Class) then
         return ADO.NO_IDENTIFIER;

      else
         return Principal'Class (From.all).Get_User_Identifier;
      end if;
   end Get_User_Identifier;

end AWA.Users.Principals;

Fix compilation warnings

Fix compilation warnings