--  Copyright (c) 2017 onox <denkpadje@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.Numerics.Generic_Elementary_Functions;

with Orka.SIMD;

package body Orka.Transforms.SIMD_Quaternions is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Vectors.Element_Type);

   function Vector_Part (Elements : Quaternion) return Vector4 is
   begin
      return Result : Vector4 := Vector4 (Elements) do
         Result (SIMD.W) := 0.0;
      end return;
   end Vector_Part;

   function "*" (Left, Right : Quaternion) return Quaternion is
      use Vectors;

      Lv : constant Vector4 := Vector_Part (Left);
      Rv : constant Vector4 := Vector_Part (Right);

      Ls : constant Vectors.Element_Type := Left (SIMD.W);
      Rs : constant Vectors.Element_Type := Right (SIMD.W);

      V : constant Vector4 := Ls * Rv + Rs * Lv + Vectors.Cross (Lv, Rv);
      S : constant Element_Type := Ls * Rs - Vectors.Dot (Lv, Rv);
   begin
      return Result : Quaternion := Quaternion (V) do
         Result (SIMD.W) := S;
      end return;
   end "*";

   function Conjugate (Elements : Quaternion) return Quaternion is
      W : constant Vectors.Element_Type := Elements (SIMD.W);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (-Vector4 (Elements)) do
         Result (SIMD.W) := W;
      end return;
   end Conjugate;

   function Norm (Elements : Quaternion) return Vectors.Element_Type is
     (Vectors.Magnitude (Vector4 (Elements)));

   function Normalize (Elements : Quaternion) return Quaternion is
     (Quaternion (Vectors.Normalize (Vector4 (Elements))));

   function Normalized (Elements : Quaternion) return Boolean is
     (Vectors.Normalized (Vector4 (Elements)));

   function R
     (Axis  : Vector4;
      Angle : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      CA : constant Vectors.Element_Type := EF.Cos (Angle / 2.0, 360.0);
      SA : constant Vectors.Element_Type := EF.Sin (Angle / 2.0, 360.0);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (Axis * SA) do
         Result (SIMD.W) := CA;
      end return;
   end R;

   function R (Left, Right : Vector4) return Quaternion is
      use type Vectors.Element_Type;

      S : constant Vector4 := Vectors.Normalize (Left);
      T : constant Vector4 := Vectors.Normalize (Right);

      E   : constant Vectors.Element_Type := Vectors.Dot (S, T);
      SRE : constant Vectors.Element_Type := EF.Sqrt (2.0 * (1.0 + E));

      use Vectors;
   begin
      --  Division by zero if Left and Right are in opposite direction.
      --  Use rotation axis perpendicular to s and angle of 180 degrees
      if SRE /= 0.0 then
         --  Equation 4.53 from chapter 4.3 Quaternions from Real-Time Rendering
         --  (third edition, 2008)
         declare
            Result : Quaternion := Quaternion ((1.0 / SRE) * Vectors.Cross (S, T));
         begin
            Result (SIMD.W) := SRE / 2.0;
            return Normalize (Result);
         end;
      else
         if abs S (SIMD.Z) < abs S (SIMD.X) then
            return R ((S (SIMD.Y), -S (SIMD.X), 0.0, 0.0), 180.0);
         else
            return R ((0.0, -S (SIMD.Z), S (SIMD.Y), 0.0), 180.0);
         end if;
      end if;
   end R;

   function Difference (Left, Right : Quaternion) return Quaternion is
   begin
      return Right * Conjugate (Left);
   end Difference;

   procedure Rotate_At_Origin
     (Vector   : in out Vector4;
      Elements : Quaternion) is
   begin
      Vector := Vectors.Vector_Type (Elements * Quaternion (Vector) * Conjugate (Elements));
   end Rotate_At_Origin;

   function Lerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;
      use Vectors;
   begin
      return Normalize (Quaternion ((1.0 - Time) * Vector4 (Left) + Time * Vector4 (Right)));
   end Lerp;

   function Slerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      Cos_Angle : constant Vectors.Element_Type := Vectors.Dot (Vector4 (Left), Vector4 (Right));
      Angle     : constant Vectors.Element_Type := EF.Arccos (Cos_Angle, 360.0);

      SA : constant Vectors.Element_Type := EF.Sin (Angle, 360.0);

      SL : constant Vectors.Element_Type := EF.Sin ((1.0 - Time) * Angle, 360.0);
      SR : constant Vectors.Element_Type := EF.Sin (Time * Angle, 360.0);

      use Vectors;
   begin
      return Quaternion ((SL / SA) * Vector4 (Left) + (SR / SA) * Vector4 (Right));
   end Slerp;

   function Image (Elements : Quaternion) return String is
     (Vectors.Image (Vectors.Vector_Type (Elements)));

end Orka.Transforms.SIMD_Quaternions;

--  Copyright (c) 2017 onox <denkpadje@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.Numerics.Generic_Elementary_Functions;

with Orka.SIMD;

package body Orka.Transforms.SIMD_Quaternions is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Vectors.Element_Type);

   function Vector_Part (Elements : Quaternion) return Vector4 is
   begin
      return Result : Vector4 := Vector4 (Elements) do
         Result (SIMD.W) := 0.0;
      end return;
   end Vector_Part;

   function "*" (Left, Right : Quaternion) return Quaternion is
      use Vectors;

      Lv : constant Vector4 := Vector_Part (Left);
      Rv : constant Vector4 := Vector_Part (Right);

      Ls : constant Vectors.Element_Type := Left (SIMD.W);
      Rs : constant Vectors.Element_Type := Right (SIMD.W);

      V : constant Vector4 := Ls * Rv + Rs * Lv + Vectors.Cross (Lv, Rv);
      S : constant Element_Type := Ls * Rs - Vectors.Dot (Lv, Rv);
   begin
      return Result : Quaternion := Quaternion (V) do
         Result (SIMD.W) := S;
      end return;
   end "*";

   function Conjugate (Elements : Quaternion) return Quaternion is
      W : constant Vectors.Element_Type := Elements (SIMD.W);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (-Vector4 (Elements)) do
         Result (SIMD.W) := W;
      end return;
   end Conjugate;

   function Norm (Elements : Quaternion) return Vectors.Element_Type is
     (Vectors.Magnitude (Vector4 (Elements)));

   function Normalize (Elements : Quaternion) return Quaternion is
     (Quaternion (Vectors.Normalize (Vector4 (Elements))));

   function Normalized (Elements : Quaternion) return Boolean is
     (Vectors.Normalized (Vector4 (Elements)));

   function R
     (Axis  : Vector4;
      Angle : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      CA : constant Vectors.Element_Type := EF.Cos (Angle / 2.0, 360.0);
      SA : constant Vectors.Element_Type := EF.Sin (Angle / 2.0, 360.0);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (Axis * SA) do
         Result (SIMD.W) := CA;
      end return;
   end R;

   function R (Left, Right : Vector4) return Quaternion is
      use type Vectors.Element_Type;

      S : constant Vector4 := Vectors.Normalize (Left);
      T : constant Vector4 := Vectors.Normalize (Right);

      E   : constant Vectors.Element_Type := Vectors.Dot (S, T);
      SRE : constant Vectors.Element_Type := EF.Sqrt (2.0 * (1.0 + E));

      use Vectors;
   begin
      --  Division by zero if Left and Right are in opposite direction.
      --  Use rotation axis perpendicular to s and angle of 180 degrees
      if SRE /= 0.0 then
         --  Equation 4.53 from chapter 4.3 Quaternions from Real-Time Rendering
         --  (third edition, 2008)
         declare
            Result : Quaternion := Quaternion ((1.0 / SRE) * Vectors.Cross (S, T));
         begin
            Result (SIMD.W) := SRE / 2.0;
            return Normalize (Result);
         end;
      else
         if abs S (SIMD.Z) < abs S (SIMD.X) then
            return R ((S (SIMD.Y), -S (SIMD.X), 0.0, 0.0), 180.0);
         else
            return R ((0.0, -S (SIMD.Z), S (SIMD.Y), 0.0), 180.0);
         end if;
      end if;
   end R;

   function Difference (Left, Right : Quaternion) return Quaternion is
   begin
      return Right * Conjugate (Left);
   end Difference;

   procedure Rotate_At_Origin
     (Vector   : in out Vector4;
      Elements : Quaternion)
   is
      Result : Vectors.Vector_Type;
   begin
      Result := Vectors.Vector_Type (Elements * Quaternion (Vector) * Conjugate (Elements));
      Vector := Result;
   end Rotate_At_Origin;

   function Lerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;
      use Vectors;
   begin
      return Normalize (Quaternion ((1.0 - Time) * Vector4 (Left) + Time * Vector4 (Right)));
   end Lerp;

   function Slerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      Cos_Angle : constant Vectors.Element_Type := Vectors.Dot (Vector4 (Left), Vector4 (Right));
      Angle     : constant Vectors.Element_Type := EF.Arccos (Cos_Angle, 360.0);

      SA : constant Vectors.Element_Type := EF.Sin (Angle, 360.0);

      SL : constant Vectors.Element_Type := EF.Sin ((1.0 - Time) * Angle, 360.0);
      SR : constant Vectors.Element_Type := EF.Sin (Time * Angle, 360.0);

      use Vectors;
   begin
      return Quaternion ((SL / SA) * Vector4 (Left) + (SR / SA) * Vector4 (Right));
   end Slerp;

   function Image (Elements : Quaternion) return String is
     (Vectors.Image (Vectors.Vector_Type (Elements)));

end Orka.Transforms.SIMD_Quaternions;

orka: Modify procedure Rotate_At_Origin to fix some failing unit tests

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  awa-setup -- Setup and installation
--  Copyright (C) 2016 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.Text_IO;
with Ada.IO_Exceptions;
with Util.Files;
with Util.Log.Loggers;
with Util.Strings;
with ASF.Events.Faces.Actions;
with ASF.Applications.Main.Configs;
with AWA.Applications;
package body AWA.Setup.Applications is

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

   package Save_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Application,
                                                      Method => Save,
                                                      Name   => "save");

   package Finish_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Application,
                                                      Method => Finish,
                                                      Name   => "finish");
   package Configure_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Application,
                                                      Method => Configure_Database,
                                                      Name   => "configure_database");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Save_Binding.Proxy'Access,
         Finish_Binding.Proxy'Access,
         Configure_Binding.Proxy'Access);

   --  Get the value identified by the name.
   function Get_Value (From : in Application;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "database_name" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Database);
      elsif Name = "database_server" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Server);
      elsif Name = "database_port" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Port);
      elsif Name = "database_user" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Property ("user"));
      elsif Name = "database_password" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Property ("password"));
      end if;
      if From.Changed.Exists (Name) then
         return Util.Beans.Objects.To_Object (String '(From.Changed.Get (Name)));
      end if;
      declare
         Param : constant String := From.Config.Get (Name);
      begin
         return Util.Beans.Objects.To_Object (Param);
      end;

   exception
      when others =>
         return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Set the value identified by the name.
   procedure Set_Value (From  : in out Application;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "database_name" then
         From.Database.Set_Database (Util.Beans.Objects.To_String (Value));
      elsif Name = "database_server" then
         From.Database.Set_Server (Util.Beans.Objects.To_String (Value));
      elsif Name = "database_port" then
         From.Database.Set_Port (Util.Beans.Objects.To_Integer (Value));
      elsif Name = "database_user" then
         From.Database.Set_Property ("user", Util.Beans.Objects.To_String (Value));
      elsif Name = "database_password" then
         From.Database.Set_Property ("password", Util.Beans.Objects.To_String (Value));
      elsif Name = "callback_url" then
         From.Changed.Set (Name, Util.Beans.Objects.To_String (Value));
         From.Changed.Set ("facebook.callback_url",
                           Util.Beans.Objects.To_String (Value) & "#{contextPath}/auth/verify");
         From.Changed.Set ("google-plus.callback_url",
                           Util.Beans.Objects.To_String (Value) & "#{contextPath}/auth/verify");
      else
         From.Changed.Set (Name, Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  Configure the database.
   procedure Configure_Database (From    : in out Application;
                                 Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Log.Info ("Configure database");
   end Configure_Database;

   --  Save the configuration.
   procedure Save (From    : in out Application;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Path     : constant String := Ada.Strings.Unbounded.To_String (From.Path);
      New_File : constant String := Path & ".tmp";
      Output   : Ada.Text_IO.File_Type;

      procedure Read_Property (Line : in String) is
         Pos : constant Natural := Util.Strings.Index (Line, '=');
      begin
         if Pos = 0 or else not From.Changed.Exists (Line (Line'First .. Pos - 1)) then
            Ada.Text_IO.Put_Line (Output, Line);
            return;
         end if;
         Ada.Text_IO.Put (Output, Line (Line'First .. Pos));
         Ada.Text_IO.Put_Line (Output, From.Changed.Get (Line (Line'First .. Pos - 1)));
      end Read_Property;

   begin
      Log.Info ("Saving configuration file {0}", Path);
      Ada.Text_IO.Create (File => Output, Name => New_File);
      Util.Files.Read_File (Path, Read_Property'Access);
      Ada.Text_IO.Close (Output);
   end Save;

   --  Finish the setup and exit the setup.
   procedure Finish (From    : in out Application;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Log.Info ("Finish configuration");
      From.Done := True;
   end Finish;

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Application)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

   --  Enter in the application setup
   procedure Setup (App    : in out Application;
                    Config : in String;
                    Server : in out ASF.Server.Container'Class) is
   begin
      Log.Info ("Entering configuration for {0}", Config);
      App.Path := Ada.Strings.Unbounded.To_Unbounded_String (Config);
      begin
         App.Config.Load_Properties (Config);
         Util.Log.Loggers.Initialize (Config);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Cannot read application configuration file: {0}", Config);
      end;
      App.Initialize (App.Config, App.Factory);
      App.Set_Global ("contextPath", App.Config.Get ("contextPath"));
      App.Set_Global ("setup",
                      Util.Beans.Objects.To_Object (App'Unchecked_Access,
                        Util.Beans.Objects.STATIC));
      App.Add_Servlet (Name   => "faces",
                       Server => App.Faces'Unchecked_Access);
      App.Add_Servlet (Name   => "files",
                       Server => App.Files'Unchecked_Access);
      App.Add_Mapping (Pattern => "*.html",
                       Name    => "faces");
      App.Add_Mapping (Pattern => "*.css",
                       Name    => "files");
      App.Add_Mapping (Pattern => "*.js",
                       Name    => "files");

      declare
         Paths : constant String := App.Get_Config (AWA.Applications.P_Module_Dir.P);
         Path  : constant String := Util.Files.Find_File_Path ("setup.xml", Paths);
      begin
         ASF.Applications.Main.Configs.Read_Configuration (App, Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Setup configuration file '{0}' does not exist", Path);
      end;

      declare
         URL : constant String := App.Config.Get ("google-plus.callback_url", "");
         Pos : Natural := Util.Strings.Index (URL, '#');
      begin
         if Pos > 0 then
            App.Changed.Set ("callback_url", URL (URL'First .. Pos - 1));
         end if;
      end;
      App.Database.Set_Connection (App.Config.Get ("database", "mysql://localhost:3306/db"));
      Server.Register_Application (App.Config.Get ("contextPath"), App'Unchecked_Access);
      Server.Start;
      while not App.Done loop
         delay 5.0;
      end loop;
   end Setup;

end AWA.Setup.Applications;

-----------------------------------------------------------------------
--  awa-setup -- Setup and installation
--  Copyright (C) 2016 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.Text_IO;
with Ada.IO_Exceptions;
with Util.Files;
with Util.Log.Loggers;
with Util.Strings;
with ASF.Events.Faces.Actions;
with ASF.Applications.Main.Configs;
with AWA.Applications;
package body AWA.Setup.Applications is

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

   package Save_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Application,
                                                      Method => Save,
                                                      Name   => "save");

   package Finish_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Application,
                                                      Method => Finish,
                                                      Name   => "finish");
   package Configure_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => Application,
                                                      Method => Configure_Database,
                                                      Name   => "configure_database");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (Save_Binding.Proxy'Access,
         Finish_Binding.Proxy'Access,
         Configure_Binding.Proxy'Access);

   --  Get the value identified by the name.
   function Get_Value (From : in Application;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "database_name" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Database);
      elsif Name = "database_server" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Server);
      elsif Name = "database_port" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Port);
      elsif Name = "database_user" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Property ("user"));
      elsif Name = "database_password" then
         return Util.Beans.Objects.To_Object (From.Database.Get_Property ("password"));
      end if;
      if From.Changed.Exists (Name) then
         return Util.Beans.Objects.To_Object (String '(From.Changed.Get (Name)));
      end if;
      declare
         Param : constant String := From.Config.Get (Name);
      begin
         return Util.Beans.Objects.To_Object (Param);
      end;

   exception
      when others =>
         return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Set the value identified by the name.
   procedure Set_Value (From  : in out Application;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "database_name" then
         From.Database.Set_Database (Util.Beans.Objects.To_String (Value));
      elsif Name = "database_server" then
         From.Database.Set_Server (Util.Beans.Objects.To_String (Value));
      elsif Name = "database_port" then
         From.Database.Set_Port (Util.Beans.Objects.To_Integer (Value));
      elsif Name = "database_user" then
         From.Database.Set_Property ("user", Util.Beans.Objects.To_String (Value));
      elsif Name = "database_password" then
         From.Database.Set_Property ("password", Util.Beans.Objects.To_String (Value));
      elsif Name = "callback_url" then
         From.Changed.Set (Name, Util.Beans.Objects.To_String (Value));
         From.Changed.Set ("facebook.callback_url",
                           Util.Beans.Objects.To_String (Value) & "#{contextPath}/auth/verify");
         From.Changed.Set ("google-plus.callback_url",
                           Util.Beans.Objects.To_String (Value) & "#{contextPath}/auth/verify");
      else
         From.Changed.Set (Name, Util.Beans.Objects.To_String (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Get the database connection string to be used by the application.
   --  ------------------------------
   function Get_Database_URL (From : in Application) return String is
      use Ada.Strings.Unbounded;

      Result : Ada.Strings.Unbounded.Unbounded_String;
   begin
      Append (Result, "mysql://");
      Append (Result, From.Database.Get_Server);
      if From.Database.Get_Port /= 0 then
         Append (Result, ":");
         Append (Result, Util.Strings.Image (From.Database.Get_Port));
      end if;
      Append (Result, "/");
      Append (Result, From.Database.Get_Database);
      if From.Database.Get_Property ("user") /= "" then
         Append (Result, "?user=");
         Append (Result, From.Database.Get_Property ("user"));
         if From.Database.Get_Property ("password") /= "" then
            Append (Result, "&password=");
            Append (Result, From.Database.Get_Property ("password"));
         end if;
      end if;
      return To_String (Result);
   end Get_Database_URL;

   --  Configure the database.
   procedure Configure_Database (From    : in out Application;
                                 Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Log.Info ("Configure database");
   end Configure_Database;

   --  Save the configuration.
   procedure Save (From    : in out Application;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      Path     : constant String := Ada.Strings.Unbounded.To_String (From.Path);
      New_File : constant String := Path & ".tmp";
      Output   : Ada.Text_IO.File_Type;

      procedure Read_Property (Line : in String) is
         Pos : constant Natural := Util.Strings.Index (Line, '=');
      begin
         if Pos = 0 or else not From.Changed.Exists (Line (Line'First .. Pos - 1)) then
            Ada.Text_IO.Put_Line (Output, Line);
            return;
         end if;
         Ada.Text_IO.Put (Output, Line (Line'First .. Pos));
         Ada.Text_IO.Put_Line (Output, From.Changed.Get (Line (Line'First .. Pos - 1)));
      end Read_Property;

   begin
      Log.Info ("Saving configuration file {0}", Path);
      Ada.Text_IO.Create (File => Output, Name => New_File);
      Util.Files.Read_File (Path, Read_Property'Access);
      Ada.Text_IO.Close (Output);
   end Save;

   --  Finish the setup and exit the setup.
   procedure Finish (From    : in out Application;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Log.Info ("Finish configuration");
      From.Done := True;
   end Finish;

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Application)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

   --  Enter in the application setup
   procedure Setup (App    : in out Application;
                    Config : in String;
                    Server : in out ASF.Server.Container'Class) is
   begin
      Log.Info ("Entering configuration for {0}", Config);
      App.Path := Ada.Strings.Unbounded.To_Unbounded_String (Config);
      begin
         App.Config.Load_Properties (Config);
         Util.Log.Loggers.Initialize (Config);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Cannot read application configuration file: {0}", Config);
      end;
      App.Initialize (App.Config, App.Factory);
      App.Set_Global ("contextPath", App.Config.Get ("contextPath"));
      App.Set_Global ("setup",
                      Util.Beans.Objects.To_Object (App'Unchecked_Access,
                        Util.Beans.Objects.STATIC));
      App.Add_Servlet (Name   => "faces",
                       Server => App.Faces'Unchecked_Access);
      App.Add_Servlet (Name   => "files",
                       Server => App.Files'Unchecked_Access);
      App.Add_Mapping (Pattern => "*.html",
                       Name    => "faces");
      App.Add_Mapping (Pattern => "*.css",
                       Name    => "files");
      App.Add_Mapping (Pattern => "*.js",
                       Name    => "files");

      declare
         Paths : constant String := App.Get_Config (AWA.Applications.P_Module_Dir.P);
         Path  : constant String := Util.Files.Find_File_Path ("setup.xml", Paths);
      begin
         ASF.Applications.Main.Configs.Read_Configuration (App, Path);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Error ("Setup configuration file '{0}' does not exist", Path);
      end;

      declare
         URL : constant String := App.Config.Get ("google-plus.callback_url", "");
         Pos : Natural := Util.Strings.Index (URL, '#');
      begin
         if Pos > 0 then
            App.Changed.Set ("callback_url", URL (URL'First .. Pos - 1));
         end if;
      end;
      App.Database.Set_Connection (App.Config.Get ("database", "mysql://localhost:3306/db"));
      Server.Register_Application (App.Config.Get ("contextPath"), App'Unchecked_Access);
      Server.Start;
      while not App.Done loop
         delay 5.0;
      end loop;
   end Setup;

end AWA.Setup.Applications;

Implement the Get_Database_URL function

Implement the Get_Database_URL function


-----------------------------------------------------------------------
--  awa-tags-modules-tests -- Unit tests for tags module
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Tags.Beans;
package body AWA.Tags.Modules.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Add_Tag",
                       Test_Add_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Remove_Tag",
                       Test_Remove_Tag'Access);
   end Add_Tests;

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access is
      Bean : Util.Beans.Basic.Readonly_Bean_Access := AWA.Tags.Beans.Create_Tag_List_Bean (Module);
   begin
      return AWA.Tags.Beans.Tag_List_Bean'Class (Bean.all)'Access;
   end Create_Tag_List_Bean;

   --  ------------------------------
   --  Test tag creation.
   --  ------------------------------
   procedure Test_Add_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-add-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         --  Create a tag.
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);

         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
      end;
   end Test_Add_Tag;

   --  ------------------------------
   --  Test tag removal.
   --  ------------------------------
   procedure Test_Remove_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-3");

         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 2, Integer (List.Get_Count), "Invalid number of tags");
      end;
   end Test_Remove_Tag;

end AWA.Tags.Modules.Tests;

-----------------------------------------------------------------------
--  awa-tags-modules-tests -- Unit tests for tags module
--  Copyright (C) 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.
-----------------------------------------------------------------------

with Util.Test_Caller;
with Util.Beans.Basic;
with Util.Beans.Objects;

with Security.Contexts;

with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Tests.Helpers.Users;
with AWA.Tags.Beans;
package body AWA.Tags.Modules.Tests is

   use Util.Tests;
   use ADO;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Add_Tag",
                       Test_Add_Tag'Access);
      Caller.Add_Test (Suite, "Test AWA.Tags.Modules.Remove_Tag",
                       Test_Remove_Tag'Access);
   end Add_Tests;

   function Create_Tag_List_Bean (Module : in Tag_Module_Access)
                                  return AWA.Tags.Beans.Tag_List_Bean_Access is
      Bean : Util.Beans.Basic.Readonly_Bean_Access := AWA.Tags.Beans.Create_Tag_List_Bean (Module);
   begin
      return AWA.Tags.Beans.Tag_List_Bean'Class (Bean.all)'Access;
   end Create_Tag_List_Bean;

   --  ------------------------------
   --  Test tag creation.
   --  ------------------------------
   procedure Test_Add_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-add-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         --  Create a tag.
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);

         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
      end;
   end Test_Add_Tag;

   --  ------------------------------
   --  Test tag removal.
   --  ------------------------------
   procedure Test_Remove_Tag (T : in out Test) is
      Sec_Ctx      : Security.Contexts.Security_Context;
      Context      : AWA.Services.Contexts.Service_Context;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-tag@test.com");

      declare
         Tag_Manager  : constant Tag_Module_Access := Get_Tag_Module;
         User         : constant AWA.Users.Models.User_Ref := Context.Get_User;
         List         : AWA.Tags.Beans.Tag_List_Bean_Access;
         Cleanup      : Util.Beans.Objects.Object;
      begin
         T.Assert (Tag_Manager /= null, "There is no tag module");

         List := Create_Tag_List_Bean (Tag_Manager);
         Cleanup := Util.Beans.Objects.To_Object (List.all'Access);
         List.Set_Value ("entity_type", Util.Beans.Objects.To_Object (String '("awa_user")));

         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Add_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-3");

         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-2");
         Tag_Manager.Remove_Tag (User.Get_Id, "awa_user", "workspaces-create", "user-tag-1");

         --  Load the list.
         List.Load_Tags (Tag_Manager.Get_Session, User.Get_Id);
         Util.Tests.Assert_Equals (T, 1, Integer (List.Get_Count), "Invalid number of tags");
      end;
   end Test_Remove_Tag;

end AWA.Tags.Modules.Tests;

Fix the tags unit test

Fix the tags unit test


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

with Ada.Strings.Unbounded;
with Ada.Exceptions;

with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Log.Loggers;

with EL.Contexts;
with EL.Contexts.Default;
with EL.Variables;
with EL.Variables.Default;

with ASF.Beans;
with ASF.Requests;
with ASF.Sessions;

with AWA.Events.Action_Method;
package body AWA.Events.Dispatchers.Actions is

   use Ada.Strings.Unbounded;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Actions");

   --  ------------------------------
   --  Dispatch the event identified by Event.
   --  The event actions which are associated with the event are executed synchronously.
   --  ------------------------------
   procedure Dispatch (Manager : in Action_Dispatcher;
                       Event   : in Module_Event'Class) is

      use Util.Beans.Objects;

      --  Dispatch the event to the event action identified by Action.
      procedure Dispatch_One (Action : in Event_Action);

      type Event_Bean is new Util.Beans.Basic.Readonly_Bean with null record;

      overriding
      function Get_Value (From : in Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  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 Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object is
         pragma Unreferenced (From);
      begin
         return Event.Get_Value (Name);
      end Get_Value;

      Variables      : aliased EL.Variables.Default.Default_Variable_Mapper;

      --  ------------------------------
      --  Default Resolver
      --  ------------------------------
      type Event_ELResolver is limited new EL.Contexts.ELResolver with record
         Request     : ASF.Requests.Request_Access;
         Application : AWA.Applications.Application_Access;
      end record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
         use Util.Beans.Basic;
         use EL.Variables;
         use type ASF.Requests.Request_Access;

         Result : Object;
         Bean   : Util.Beans.Basic.Readonly_Bean_Access;
         Scope  : ASF.Beans.Scope_Type;
         Key    : constant String := To_String (Name);
      begin
         if Base /= null then
            return Base.Get_Value (Key);
         end if;

         if Resolver.Request /= null then
            Result := Resolver.Request.Get_Attribute (Key);
            if not Util.Beans.Objects.Is_Null (Result) then
               return Result;
            end if;

            --  If there is a session, look if the attribute is defined there.
            declare
               Session : constant ASF.Sessions.Session := Resolver.Request.Get_Session;
            begin
               if Session.Is_Valid then
                  Result := Session.Get_Attribute (Key);
                  if not Util.Beans.Objects.Is_Null (Result) then
                     return Result;
                  end if;
               end if;
            end;
         end if;

         Resolver.Application.Create (Name, Context, Bean, Scope);
         if Bean = null then
            return Resolver.Application.Get_Global (Name, Context);
         end if;
         Result := To_Object (Bean);
         if Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Key, Result);
         else
            Variables.Bind (Key, Result);
         end if;
         return Result;
      end Get_Value;

      --  ------------------------------
      --  Set the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object) is
         pragma Unreferenced (Context);
         use type ASF.Requests.Request_Access;

         Key : constant String := To_String (Name);
      begin
         if Base /= null then
            Base.Set_Value (Name => Key, Value => Value);
         elsif Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Name => Key, Value => Value);
         else
            Variables.Bind (To_String (Name), Value);
         end if;
      end Set_Value;

      Local_Event    : aliased Event_Bean;
      Resolver       : aliased Event_ELResolver;
      ELContext      : aliased EL.Contexts.Default.Default_Context;

      --  ------------------------------
      --  Dispatch the event to the event action identified by Action.
      --  ------------------------------
      procedure Dispatch_One (Action : in Event_Action) is
         use Ada.Exceptions;

         Method : EL.Expressions.Method_Info;
      begin
         Method := Action.Action.Get_Method_Info (Context => ELContext);

         if Method.Object.all in Util.Beans.Basic.Bean'Class then
            --  If we have a prepare method and the bean provides a Set_Value method,
            --  call the preparation method to fill the bean with some values.
            EL.Beans.Initialize (Util.Beans.Basic.Bean'Class (Method.Object.all),
                                 Action.Properties,
                                 ELContext);
         end if;

         --  Execute the specified method on the bean and give it the event object.
         AWA.Events.Action_Method.Execute (Method => Method,
                                           Param  => Event);

         --  If an exception is raised by the action, do not propagate it:
         --   o We have to dispatch the event to other actions.
         --   o The event may be dispatched asynchronously and there is no handler
         --     that could handle such exception
      exception
         when E : others =>
            Log.Error ("Error when executing event action {0}: {1}: {2}",
                       Action.Action.Get_Expression, Exception_Name (E), Exception_Message (E));
      end Dispatch_One;

      Pos  : Event_Action_Lists.Cursor := Manager.Actions.First;
   begin
      Resolver.Application := Manager.Application;

      ELContext.Set_Resolver (Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Variables.Bind (Name  => "event",
                      Value => To_Object (Local_Event'Unchecked_Access, STATIC));

      while Event_Action_Lists.Has_Element (Pos) loop
         Event_Action_Lists.Query_Element (Pos, Dispatch_One'Access);
         Event_Action_Lists.Next (Pos);
      end loop;
   end Dispatch;

   --  ------------------------------
   --  Add an action invoked when an event is dispatched through this dispatcher.
   --  When the event queue dispatches the event, the Ada bean identified by the method action
   --  represented by Action is created and initialized by evaluating and setting the
   --  parameters defined in Params.  The action method is then invoked.
   --  ------------------------------
   procedure Add_Action (Manager : in out Action_Dispatcher;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is

      Item : Event_Action;
   begin
      Item.Action     := Action;
      Item.Properties := Params;
      Manager.Actions.Append (Item);
   end Add_Action;

   --  ------------------------------
   --  Create a new dispatcher associated with the application.
   --  ------------------------------
   function Create_Dispatcher (Application : in AWA.Applications.Application_Access)
                               return Dispatcher_Access is
      Result : constant Dispatcher_Access := new Action_Dispatcher '(Dispatcher with
                                                                     Application => Application,
                                                                     others => <>);
   begin
      return Result.all'Access;
   end Create_Dispatcher;

end AWA.Events.Dispatchers.Actions;

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

with Ada.Strings.Unbounded;
with Ada.Exceptions;

with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Log.Loggers;

with EL.Contexts;
with EL.Contexts.TLS;
with EL.Variables;
with EL.Variables.Default;

with ASF.Beans;
with ASF.Requests;
with ASF.Sessions;

with AWA.Events.Action_Method;
package body AWA.Events.Dispatchers.Actions is

   use Ada.Strings.Unbounded;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Dispatchers.Actions");

   --  ------------------------------
   --  Dispatch the event identified by Event.
   --  The event actions which are associated with the event are executed synchronously.
   --  ------------------------------
   procedure Dispatch (Manager : in Action_Dispatcher;
                       Event   : in Module_Event'Class) is

      use Util.Beans.Objects;

      --  Dispatch the event to the event action identified by Action.
      procedure Dispatch_One (Action : in Event_Action);

      type Event_Bean is new Util.Beans.Basic.Readonly_Bean with null record;

      overriding
      function Get_Value (From : in Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  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 Event_Bean;
                          Name : in String) return Util.Beans.Objects.Object is
         pragma Unreferenced (From);
      begin
         return Event.Get_Value (Name);
      end Get_Value;

      Variables      : aliased EL.Variables.Default.Default_Variable_Mapper;

      --  ------------------------------
      --  Default Resolver
      --  ------------------------------
      type Event_ELResolver is limited new EL.Contexts.ELResolver with record
         Request     : ASF.Requests.Request_Access;
         Application : AWA.Applications.Application_Access;
      end record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object);

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
         use Util.Beans.Basic;
         use EL.Variables;
         use type ASF.Requests.Request_Access;

         Result : Object;
         Bean   : Util.Beans.Basic.Readonly_Bean_Access;
         Scope  : ASF.Beans.Scope_Type;
         Key    : constant String := To_String (Name);
      begin
         if Base /= null then
            return Base.Get_Value (Key);
         end if;

         if Resolver.Request /= null then
            Result := Resolver.Request.Get_Attribute (Key);
            if not Util.Beans.Objects.Is_Null (Result) then
               return Result;
            end if;

            --  If there is a session, look if the attribute is defined there.
            declare
               Session : constant ASF.Sessions.Session := Resolver.Request.Get_Session;
            begin
               if Session.Is_Valid then
                  Result := Session.Get_Attribute (Key);
                  if not Util.Beans.Objects.Is_Null (Result) then
                     return Result;
                  end if;
               end if;
            end;
         end if;

         Resolver.Application.Create (Name, Context, Bean, Scope);
         if Bean = null then
            return Resolver.Application.Get_Global (Name, Context);
         end if;
         Result := To_Object (Bean);
         if Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Key, Result);
         else
            Variables.Bind (Key, Result);
         end if;
         return Result;
      end Get_Value;

      --  ------------------------------
      --  Set the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      procedure Set_Value (Resolver : in out Event_ELResolver;
                           Context  : in EL.Contexts.ELContext'Class;
                           Base     : access Util.Beans.Basic.Bean'Class;
                           Name     : in Unbounded_String;
                           Value    : in Util.Beans.Objects.Object) is
         pragma Unreferenced (Context);
         use type ASF.Requests.Request_Access;

         Key : constant String := To_String (Name);
      begin
         if Base /= null then
            Base.Set_Value (Name => Key, Value => Value);
         elsif Resolver.Request /= null then
            Resolver.Request.Set_Attribute (Name => Key, Value => Value);
         else
            Variables.Bind (To_String (Name), Value);
         end if;
      end Set_Value;

      Local_Event    : aliased Event_Bean;
      Resolver       : aliased Event_ELResolver;
      ELContext      : aliased EL.Contexts.TLS.TLS_Context;

      --  ------------------------------
      --  Dispatch the event to the event action identified by Action.
      --  ------------------------------
      procedure Dispatch_One (Action : in Event_Action) is
         use Ada.Exceptions;

         Method : EL.Expressions.Method_Info;
      begin
         Method := Action.Action.Get_Method_Info (Context => ELContext);

         if Method.Object.all in Util.Beans.Basic.Bean'Class then
            --  If we have a prepare method and the bean provides a Set_Value method,
            --  call the preparation method to fill the bean with some values.
            EL.Beans.Initialize (Util.Beans.Basic.Bean'Class (Method.Object.all),
                                 Action.Properties,
                                 ELContext);
         end if;

         --  Execute the specified method on the bean and give it the event object.
         AWA.Events.Action_Method.Execute (Method => Method,
                                           Param  => Event);

         --  If an exception is raised by the action, do not propagate it:
         --   o We have to dispatch the event to other actions.
         --   o The event may be dispatched asynchronously and there is no handler
         --     that could handle such exception
      exception
         when E : others =>
            Log.Error ("Error when executing event action {0}: {1}: {2}",
                       Action.Action.Get_Expression, Exception_Name (E), Exception_Message (E));
      end Dispatch_One;

      Pos  : Event_Action_Lists.Cursor := Manager.Actions.First;
   begin
      Resolver.Application := Manager.Application;

      ELContext.Set_Resolver (Resolver'Unchecked_Access);
      ELContext.Set_Variable_Mapper (Variables'Unchecked_Access);

      Variables.Bind (Name  => "event",
                      Value => To_Object (Local_Event'Unchecked_Access, STATIC));

      while Event_Action_Lists.Has_Element (Pos) loop
         Event_Action_Lists.Query_Element (Pos, Dispatch_One'Access);
         Event_Action_Lists.Next (Pos);
      end loop;
   end Dispatch;

   --  ------------------------------
   --  Add an action invoked when an event is dispatched through this dispatcher.
   --  When the event queue dispatches the event, the Ada bean identified by the method action
   --  represented by Action is created and initialized by evaluating and setting the
   --  parameters defined in Params.  The action method is then invoked.
   --  ------------------------------
   procedure Add_Action (Manager : in out Action_Dispatcher;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is

      Item : Event_Action;
   begin
      Item.Action     := Action;
      Item.Properties := Params;
      Manager.Actions.Append (Item);
   end Add_Action;

   --  ------------------------------
   --  Create a new dispatcher associated with the application.
   --  ------------------------------
   function Create_Dispatcher (Application : in AWA.Applications.Application_Access)
                               return Dispatcher_Access is
      Result : constant Dispatcher_Access := new Action_Dispatcher '(Dispatcher with
                                                                     Application => Application,
                                                                     others => <>);
   begin
      return Result.all'Access;
   end Create_Dispatcher;

end AWA.Events.Dispatchers.Actions;

Use a thread local EL context when an event action is executed. This allows the action handler to use the same EL context easily.


-----------------------------------------------------------------------
--  gen-commands-page -- Page creation command for dynamo
--  Copyright (C) 2011, 2017, 2018 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 Gen.Commands.Page is

   --  ------------------------------
   --  Page Creation Command
   --  ------------------------------
   --  This command adds a XHTML page to the web application.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in out Command;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Page;

-----------------------------------------------------------------------
--  gen-commands-page -- Page creation command for dynamo
--  Copyright (C) 2011, 2017, 2018, 2019 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 Gen.Commands.Page is

   --  ------------------------------
   --  Page Creation Command
   --  ------------------------------
   --  This command adds a XHTML page to the web application.
   type Command is new Gen.Commands.Command with null record;

   --  Execute the command with the arguments.
   overriding
   procedure Execute (Cmd       : in out Command;
                      Name      : in String;
                      Args      : in Argument_List'Class;
                      Generator : in out Gen.Generator.Handler);

   --  Write the help associated with the command.
   overriding
   procedure Help (Cmd       : in out Command;
                   Name      : in String;
                   Generator : in out Gen.Generator.Handler);

end Gen.Commands.Page;

Add Name parameter to the Help procedure


-----------------------------------------------------------------------
--  volume_server -- Example of server with a servlet
--  Copyright (C) 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.Server.Web;
with ASF.Servlets;
with Volume_Servlet;

procedure Volume_Server is
   Compute : aliased Volume_Servlet.Servlet;
   App     : aliased ASF.Servlets.Servlet_Registry;
   WS      : ASF.Server.Web.AWS_Container;
begin
   --  Register the servlets and filters
   App.Add_Servlet (Name => "compute", Server => Compute'Unchecked_Access);

   --  Define servlet mappings
   App.Add_Mapping (Name => "compute", Pattern => "*.html");

   WS.Register_Application ("/volume", App'Unchecked_Access);

   WS.Start;

   delay 60.0;

end Volume_Server;

-----------------------------------------------------------------------
--  volume_server -- Example of server with a servlet
--  Copyright (C) 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.Server.Web;
with ASF.Servlets;
with Volume_Servlet;
with Util.Log.Loggers;

procedure Volume_Server is
   Compute : aliased Volume_Servlet.Servlet;
   App     : aliased ASF.Servlets.Servlet_Registry;
   WS      : ASF.Server.Web.AWS_Container;
   Log     : Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Volume_Server");
begin
   --  Register the servlets and filters
   App.Add_Servlet (Name => "compute", Server => Compute'Unchecked_Access);

   --  Define servlet mappings
   App.Add_Mapping (Name => "compute", Pattern => "*.html");

   WS.Register_Application ("/volume", App'Unchecked_Access);

   Log.Info ("Connect you browser to: http://localhost:8080/volume/compute.html");

   WS.Start;

   delay 60.0;

end Volume_Server;

Add a log message to indicate the URL to connect to


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

   type String_Ptr is access all String;

   subtype Uint8 is Interfaces.Unsigned_8;

   subtype Uint16 is Interfaces.Unsigned_16;

   subtype Uint32 is Interfaces.Unsigned_32;

   subtype Uint64 is Interfaces.Unsigned_64;

   subtype Target_Addr is Interfaces.Unsigned_64;

   subtype Target_Size is Interfaces.Unsigned_64;

   subtype Target_Offset is Interfaces.Unsigned_64;

   type Target_Tick_Ref is new Uint64;

   type Target_Thread_Ref is new Uint32;

   subtype Target_Process_Ref is Uint32;

   subtype Target_Time is Target_Tick_Ref;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value : in Uint32;
                       Length : in Positive := 8) return String;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String;

   --  Format the target time to a printable representation.
   function Tick_Image (Value : in Target_Tick_Ref) return String;

   function "-" (Left, Right : in Target_Tick_Ref) return Target_Tick_Ref;

end MAT.Types;

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

   pragma Preelaborate;

   type String_Ptr is access all String;

   subtype Uint8 is Interfaces.Unsigned_8;

   subtype Uint16 is Interfaces.Unsigned_16;

   subtype Uint32 is Interfaces.Unsigned_32;

   subtype Uint64 is Interfaces.Unsigned_64;

   subtype Target_Addr is Interfaces.Unsigned_64;

   subtype Target_Size is Interfaces.Unsigned_64;

   subtype Target_Offset is Interfaces.Unsigned_64;

   type Target_Tick_Ref is new Uint64;

   type Target_Thread_Ref is new Uint32;

   subtype Target_Process_Ref is Uint32;

   subtype Target_Time is Target_Tick_Ref;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value : in Uint32;
                       Length : in Positive := 8) return String;

   --  Return an hexadecimal string representation of the value.
   function Hex_Image (Value  : in Uint64;
                       Length : in Positive := 16) return String;

   --  Format the target time to a printable representation.
   function Tick_Image (Value : in Target_Tick_Ref) return String;

   function "-" (Left, Right : in Target_Tick_Ref) return Target_Tick_Ref;

end MAT.Types;

Add pragma Preelaborate

Add pragma Preelaborate


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

with Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;

package body Security.Policies is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

end Security.Policies;

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

with Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;

package body Security.Policies is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access) is
   begin
      Manager.Manager.Add_Permission (Name, Permission);
   end Add_Permission;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      use type Permissions.Permission_Index;

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;
      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String) is

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

      --  Read the configuration file.
      Reader.Parse (File);

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

            --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
            --  'missing "with" clause on package "Security.Controllers"'
            --  if we use the 'Security.Controller_Access' type, even if this "with" clause exist.
            --  gcc 4.4.3 under Ubuntu does not have this issue.
            --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler bug
            --  but we have to use a temporary variable and do some type conversion...
            declare
               P : Controller_Access := Manager.Permissions (I).all'Access;
            begin
               Free (P);
               Manager.Permissions (I) := null;
            end;
         end loop;
         Free (Manager.Permissions);
      end if;
   end Finalize;

end Security.Policies;

Implement the new function Get_Policy_Index