-----------------------------------------------------------------------
--  awa-wikis-modules -- Module wikis
--  Copyright (C) 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 ASF.Applications;

with ADO;
with ADO.Sessions;
with AWA.Events;
with AWA.Modules;
with AWA.Modules.Lifecycles;
with AWA.Wikis.Models;
with AWA.Tags.Beans;
with AWA.Counters.Definition;
with Security.Permissions;

--  == Events ==
--  The <tt>wikis</tt> exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === wiki-create-page ===
--  This event is posted when a new wiki page is created.
--
--  === wiki-create-content ===
--  This event is posted when a new wiki page content is created.  Each time a wiki page is
--  modified, a new wiki page content is created and this event is posted.
--
package AWA.Wikis.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "wikis";

   package ACL_Create_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-create");
   package ACL_Delete_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-delete");
   package ACL_Update_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-update");
   package ACL_View_Wiki_Page is new Security.Permissions.Definition ("wiki-page-view");

   --  Define the permissions.
   package ACL_Create_Wiki_Space is new Security.Permissions.Definition ("wiki-space-create");
   package ACL_Delete_Wiki_Space is new Security.Permissions.Definition ("wiki-space-delete");
   package ACL_Update_Wiki_Space is new Security.Permissions.Definition ("wiki-space-update");

   --  Event posted when a new wiki page is created.
   package Create_Page_Event is new AWA.Events.Definition (Name => "wiki-create-page");

   --  Event posted when a new wiki content is created.
   package Create_Content_Event is new AWA.Events.Definition (Name => "wiki-create-content");

   --  Define the read wiki page counter.
   package Read_Counter is new AWA.Counters.Definition (Models.WIKI_PAGE_TABLE, "read_count");

   package Wiki_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Wikis.Models.Wiki_Page_Ref'Class);

   subtype Listener is Wiki_Lifecycle.Listener;

   --  The configuration parameter that defines a list of wiki page ID to copy when a new
   --  wiki space is created.
   PARAM_WIKI_COPY_LIST : constant String := "wiki_copy_list";

   --  ------------------------------
   --  Module wikis
   --  ------------------------------
   type Wiki_Module is new AWA.Modules.Module with private;
   type Wiki_Module_Access is access all Wiki_Module'Class;

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

   --  Get the wikis module.
   function Get_Wiki_Module return Wiki_Module_Access;

   --  Create the wiki space.
   procedure Create_Wiki_Space (Module : in Wiki_Module;
                                Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Save the wiki space.
   procedure Save_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Load the wiki space.
   procedure Load_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class;
                              Id     : in ADO.Identifier);

   --  Create the wiki page into the wiki space.
   procedure Create_Wiki_Page (Model   : in Wiki_Module;
                               Into    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                               Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                               Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save the wiki page.
   procedure Save (Model  : in Wiki_Module;
                   Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Delete the wiki page as well as all its versions.
   procedure Delete (Model  : in Wiki_Module;
                     Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Load the wiki page and its content.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Id      : in ADO.Identifier);

   --  Load the wiki page and its content from the wiki space Id and the page name.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Wiki    : in ADO.Identifier;
                        Name    : in String);

   --  Create a new wiki content for the wiki page.
   procedure Create_Wiki_Content (Model   : in Wiki_Module;
                                  Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                  Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

private
   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page_Id : in ADO.Identifier);

   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page    : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                DB      : in out ADO.Sessions.Master_Session;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   type Wiki_Module is new AWA.Modules.Module with null record;

end AWA.Wikis.Modules;

-----------------------------------------------------------------------
--  awa-wikis-modules -- Module wikis
--  Copyright (C) 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 ASF.Applications;

with ADO;
with ADO.Sessions;
with AWA.Events;
with AWA.Modules;
with AWA.Modules.Lifecycles;
with AWA.Wikis.Models;
with AWA.Tags.Beans;
with AWA.Counters.Definition;
with Security.Permissions;

--  == Events ==
--  The <tt>wikis</tt> exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === wiki-create-page ===
--  This event is posted when a new wiki page is created.
--
--  === wiki-create-content ===
--  This event is posted when a new wiki page content is created.  Each time a wiki page is
--  modified, a new wiki page content is created and this event is posted.
--
package AWA.Wikis.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "wikis";

   package ACL_Create_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-create");
   package ACL_Delete_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-delete");
   package ACL_Update_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-update");
   package ACL_View_Wiki_Page is new Security.Permissions.Definition ("wiki-page-view");

   --  Define the permissions.
   package ACL_Create_Wiki_Space is new Security.Permissions.Definition ("wiki-space-create");
   package ACL_Delete_Wiki_Space is new Security.Permissions.Definition ("wiki-space-delete");
   package ACL_Update_Wiki_Space is new Security.Permissions.Definition ("wiki-space-update");

   --  Event posted when a new wiki page is created.
   package Create_Page_Event is new AWA.Events.Definition (Name => "wiki-create-page");

   --  Event posted when a new wiki content is created.
   package Create_Content_Event is new AWA.Events.Definition (Name => "wiki-create-content");

   --  Define the read wiki page counter.
   package Read_Counter is new AWA.Counters.Definition (Models.WIKI_PAGE_TABLE, "read_count");

   package Wiki_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Wikis.Models.Wiki_Page_Ref'Class);

   subtype Listener is Wiki_Lifecycle.Listener;

   --  The configuration parameter that defines a list of wiki page ID to copy when a new
   --  wiki space is created.
   PARAM_WIKI_COPY_LIST : constant String := "wiki_copy_list";

   --  Exception raised when a wiki page name is already used for the wiki space.
   Name_Used : exception;

   --  ------------------------------
   --  Module wikis
   --  ------------------------------
   type Wiki_Module is new AWA.Modules.Module with private;
   type Wiki_Module_Access is access all Wiki_Module'Class;

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

   --  Get the wikis module.
   function Get_Wiki_Module return Wiki_Module_Access;

   --  Create the wiki space.
   procedure Create_Wiki_Space (Module : in Wiki_Module;
                                Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Save the wiki space.
   procedure Save_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Load the wiki space.
   procedure Load_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class;
                              Id     : in ADO.Identifier);

   --  Create the wiki page into the wiki space.
   procedure Create_Wiki_Page (Model   : in Wiki_Module;
                               Into    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                               Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                               Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save the wiki page.
   procedure Save (Model  : in Wiki_Module;
                   Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Delete the wiki page as well as all its versions.
   procedure Delete (Model  : in Wiki_Module;
                     Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Load the wiki page and its content.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Id      : in ADO.Identifier);

   --  Load the wiki page and its content from the wiki space Id and the page name.
   procedure Load_Page (Model   : in Wiki_Module;
                        Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                        Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class;
                        Tags    : in out AWA.Tags.Beans.Tag_List_Bean;
                        Wiki    : in ADO.Identifier;
                        Name    : in String);

   --  Create a new wiki content for the wiki page.
   procedure Create_Wiki_Content (Model   : in Wiki_Module;
                                  Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                  Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

private
   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page_Id : in ADO.Identifier);

   --  Copy the wiki page with its last version to the wiki space.
   procedure Copy_Page (Module  : in Wiki_Module;
                        DB      : in out ADO.Sessions.Master_Session;
                        Wiki    : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                        Page    : in AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Save a new wiki content for the wiki page.
   procedure Save_Wiki_Content (Model   : in Wiki_Module;
                                DB      : in out ADO.Sessions.Master_Session;
                                Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

   type Wiki_Module is new AWA.Modules.Module with null record;

end AWA.Wikis.Modules;

Declare the Name_Used exception

Declare the Name_Used exception


-----------------------------------------------------------------------
--  EL.Objects.Time.Tests - Testsuite time objects
--  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 Util.Test_Caller;
with Ada.Calendar.Formatting;
with Util.Log.Loggers;
with Util.Tests;
package body EL.Objects.Time.Tests is

   use Ada.Calendar;
   use Util.Log;
   use Util.Tests;

   LOG : constant Util.Log.Loggers.Logger := Loggers.Create ("Tests");

   --  ------------------------------
   --  Test evaluation of expression using a bean
   --  ------------------------------
   procedure Test_Time_Object (T : in out Test) is
      C : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      V : constant EL.Objects.Object := To_Object (C);
   begin
      T.Assert (Is_Null (V) = False, "Object holding a time value must not be null");
      T.Assert (Is_Empty (V) = False, "Object holding a time value must not be empty");
      T.Assert (Get_Type (V) = TYPE_TIME, "Object holding a time value must be TYPE_TIME");

      T.Assert (C = To_Time (V), "Invalid time returned by To_Time");
   end Test_Time_Object;

   --  ------------------------------
   --  Test time to string conversion
   --  ------------------------------
   procedure Test_Time_To_String (T : in out Test) is
      C  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      V  : constant EL.Objects.Object := To_Object (C);
      S  : constant EL.Objects.Object := Cast_String (V);
      V2 : constant EL.Objects.Object := Cast_Time (S);
   begin
      --  Both 3 values should be the same.
      LOG.Info ("Time S : {0}", To_String (S));
      LOG.Info ("Time V : {0}", To_String (V));
      LOG.Info ("Time V2: {0}", To_String (V2));

      Assert_Equals (T, To_String (S), To_String (V), "Invalid time conversion (V)");
      Assert_Equals (T, To_String (S), To_String (V2), "Invalid time conversion (V2)");

      --  The Cast_String looses accuracy so V and V2 may not be equal.
      T.Assert (V >= V2, "Invalid time to string conversion");

      --  Check the time value taking into account the 1 sec accuracy that was lost.
      T.Assert (C >= To_Time (V2), "Invalid time returned by To_Time (T > expected)");
      T.Assert (C < To_Time (V2) + 1.0, "Invalid time returned by To_Time (T + 1 < expected)");
   end Test_Time_To_String;

   --  ------------------------------
   --  Test time add and subtract
   --  ------------------------------
   procedure Test_Time_Add (T : in out Test) is
      C  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      V  : constant EL.Objects.Object := To_Object (C);
      Dt : constant EL.Objects.Object := To_Object (Integer (10));
      V2 : constant EL.Objects.Object := V + Dt;
      V3 : constant EL.Objects.Object := V2 - Dt;
   begin
      T.Assert (V3 = V, "Adding and substracting 10 seconds should result in the same time");
      T.Assert (V2 > V, "Invalid comparison for time");
      T.Assert (V3 < V2, "Invalid comparison for time");
   end Test_Time_Add;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_Object - Is_Null, Is_Empty, Get_Type",
                       Test_Time_Object'Access);
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_Object - To_Time",
                       Test_Time_Object'Access);
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_String - Cast_Time",
                       Test_Time_To_String'Access);
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_String - Cast_Time",
                       Test_Time_Add'Access);
   end Add_Tests;

end EL.Objects.Time.Tests;

-----------------------------------------------------------------------
--  EL.Objects.Time.Tests - Testsuite time objects
--  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 Util.Test_Caller;
with Ada.Calendar.Formatting;
with Util.Log.Loggers;
with Util.Tests;
package body EL.Objects.Time.Tests is

   use Ada.Calendar;
   use Util.Log;
   use Util.Tests;

   LOG : constant Util.Log.Loggers.Logger := Loggers.Create ("Tests");

   --  ------------------------------
   --  Test evaluation of expression using a bean
   --  ------------------------------
   procedure Test_Time_Object (T : in out Test) is
      C : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      V : constant EL.Objects.Object := To_Object (C);
   begin
      T.Assert (Is_Null (V) = False, "Object holding a time value must not be null");
      T.Assert (Is_Empty (V) = False, "Object holding a time value must not be empty");
      T.Assert (Get_Type (V) = TYPE_TIME, "Object holding a time value must be TYPE_TIME");

      T.Assert (C = To_Time (V), "Invalid time returned by To_Time");
   end Test_Time_Object;

   --  ------------------------------
   --  Test time to string conversion
   --  ------------------------------
   procedure Test_Time_To_String (T : in out Test) is
      C  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      V  : constant EL.Objects.Object := To_Object (C);
      S  : constant EL.Objects.Object := Cast_String (V);
      V2 : constant EL.Objects.Object := Cast_Time (S);
   begin
      --  Both 3 values should be the same.
      LOG.Info ("Time S : {0}", To_String (S));
      LOG.Info ("Time V : {0}", To_String (V));
      LOG.Info ("Time V2: {0}", To_String (V2));

      Assert_Equals (T, To_String (S), To_String (V), "Invalid time conversion (V)");
      Assert_Equals (T, To_String (S), To_String (V2), "Invalid time conversion (V2)");

      --  The Cast_String looses accuracy so V and V2 may not be equal.
      T.Assert (V >= V2, "Invalid time to string conversion");

      --  Check the time value taking into account the 1 sec accuracy that was lost.
      T.Assert (C >= To_Time (V2), "Invalid time returned by To_Time (T > expected)");
      T.Assert (C < To_Time (V2) + 1.0, "Invalid time returned by To_Time (T + 1 < expected)");
   end Test_Time_To_String;

   --  ------------------------------
   --  Test time add and subtract
   --  ------------------------------
   procedure Test_Time_Add (T : in out Test) is
      C  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      V  : constant EL.Objects.Object := To_Object (C);
      Dt : constant EL.Objects.Object := To_Object (Integer (10));
      V2 : constant EL.Objects.Object := V + Dt;
      V3 : constant EL.Objects.Object := V2 - Dt;
   begin
      T.Assert (V3 = V, "Adding and substracting 10 seconds should result in the same time");
      T.Assert (V2 > V, "Invalid comparison for time");
      T.Assert (V3 < V2, "Invalid comparison for time");
   end Test_Time_Add;

   package Caller is new Util.Test_Caller (Test, "EL.Objects.Time");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      --  Test_Bean verifies several methods.  Register several times
      --  to enumerate what is tested.
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_Object - Is_Null, Is_Empty, Get_Type",
                       Test_Time_Object'Access);
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_Object - To_Time",
                       Test_Time_Object'Access);
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_String - Cast_Time",
                       Test_Time_To_String'Access);
      Caller.Add_Test (Suite, "Test EL.Objects.Time.To_String - Cast_Time",
                       Test_Time_Add'Access);
   end Add_Tests;

end EL.Objects.Time.Tests;

Use the test name EL.Objects.Time

Use the test name EL.Objects.Time


-----------------------------------------------------------------------
--  util-streams-buffered -- Buffered streams utilities
--  Copyright (C) 2010, 2013, 2015, 2016, 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.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;

--  == Buffered Streams ==
--  The `Output_Buffer_Stream` and `Input_Buffer_Stream` implement an output
--  and input stream respectively which manages an output or input buffer.  The data is
--  first written to the buffer and when the buffer is full or flushed, it gets written
--  to the target output stream.
--
--  The `Output_Buffer_Stream` must be initialized to indicate the buffer size as well
--  as the target output stream onto which the data will be flushed.  For example, a
--  pipe stream could be created and configured to use the buffer as follows:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Output_Buffer_Stream;
--       ...
--          Buffer.Initialize (Output => Pipe'Unchecked_Access, Size => 1024);
--
--  In this example, the buffer of 1024 bytes is configured to flush its content to the
--  pipe input stream so that what is written to the buffer will be received as input by
--  the program.
--  The `Output_Buffer_Stream` provides write operation that deal only with binary data
--  (`Stream_Element`).  To write text, it is best to use the `Print_Stream` type from
--  the `Util.Streams.Texts` package as it extends the `Output_Buffer_Stream` and provides
--  several operations to write character and strings.
--
--  The `Input_Buffer_Stream` must also be initialized to also indicate the buffer size
--  and either an input stream or an input content.  When configured, the input stream is used
--  to fill the input stream buffer.  The buffer configuration is very similar as the
--  output stream:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Input_Buffer_Stream;
--       ...
--          Buffer.Initialize (Input => Pipe'Unchecked_Access, Size => 1024);
--
--  In this case, the buffer of 1024 bytes is filled by reading the pipe stream, and thus
--  getting the program's output.
package Util.Streams.Buffered is

   pragma Preelaborate;

   type Buffer_Access is access Ada.Streams.Stream_Element_Array;

   --  -----------------------
   --  Output buffer stream
   --  -----------------------
   --  The Output_Buffer_Stream is an output stream which uses
   --  an intermediate buffer to write the data.
   --
   --  It is necessary to call Flush to make sure the data
   --  is written to the target stream.  The Flush operation will
   --  be called when finalizing the output buffer stream.
   type Output_Buffer_Stream is limited new Output_Stream with private;

   --  Initialize the stream to write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : in Output_Stream_Access;
                         Size    : in Positive);

   --  Initialize the stream with a buffer of Size bytes.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream);

   --  Get the direct access to the buffer.
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access;

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream);

   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer stream to the unbounded string.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Get the number of element in the stream.
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural;

   type Input_Buffer_Stream is limited new Input_Stream with private;

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String);

   --  Initialize the stream to read the given streams.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : in Input_Stream_Access;
                         Size    : in Positive);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Input_Buffer_Stream);

   --  Read one character from the input stream.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Returns True if the end of the stream is reached.
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean;

private

   use Ada.Streams;

   type Output_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The output stream to use for flushing the buffer.
      Output      : Output_Stream_Access := null;

      No_Flush    : Boolean := False;
   end record;

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Object : in out Output_Buffer_Stream);

   type Input_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Input_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The input stream to use to fill the buffer.
      Input       : Input_Stream_Access := null;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

   --  Release the buffer.
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream);

end Util.Streams.Buffered;

-----------------------------------------------------------------------
--  util-streams-buffered -- Buffered streams utilities
--  Copyright (C) 2010, 2013, 2015, 2016, 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.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Finalization;

--  == Buffered Streams ==
--  The `Output_Buffer_Stream` and `Input_Buffer_Stream` implement an output
--  and input stream respectively which manages an output or input buffer.  The data is
--  first written to the buffer and when the buffer is full or flushed, it gets written
--  to the target output stream.
--
--  The `Output_Buffer_Stream` must be initialized to indicate the buffer size as well
--  as the target output stream onto which the data will be flushed.  For example, a
--  pipe stream could be created and configured to use the buffer as follows:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Output_Buffer_Stream;
--       ...
--          Buffer.Initialize (Output => Pipe'Unchecked_Access,
--                             Size => 1024);
--
--  In this example, the buffer of 1024 bytes is configured to flush its content to the
--  pipe input stream so that what is written to the buffer will be received as input by
--  the program.
--  The `Output_Buffer_Stream` provides write operation that deal only with binary data
--  (`Stream_Element`).  To write text, it is best to use the `Print_Stream` type from
--  the `Util.Streams.Texts` package as it extends the `Output_Buffer_Stream` and provides
--  several operations to write character and strings.
--
--  The `Input_Buffer_Stream` must also be initialized to also indicate the buffer size
--  and either an input stream or an input content.  When configured, the input stream is used
--  to fill the input stream buffer.  The buffer configuration is very similar as the
--  output stream:
--
--    with Util.Streams.Buffered;
--    with Util.Streams.Pipes;
--    ...
--       Pipe   : aliased Util.Streams.Pipes.Pipe_Stream;
--       Buffer : Util.Streams.Buffered.Input_Buffer_Stream;
--       ...
--          Buffer.Initialize (Input => Pipe'Unchecked_Access, Size => 1024);
--
--  In this case, the buffer of 1024 bytes is filled by reading the pipe stream, and thus
--  getting the program's output.
package Util.Streams.Buffered is

   pragma Preelaborate;

   type Buffer_Access is access Ada.Streams.Stream_Element_Array;

   --  -----------------------
   --  Output buffer stream
   --  -----------------------
   --  The Output_Buffer_Stream is an output stream which uses
   --  an intermediate buffer to write the data.
   --
   --  It is necessary to call Flush to make sure the data
   --  is written to the target stream.  The Flush operation will
   --  be called when finalizing the output buffer stream.
   type Output_Buffer_Stream is limited new Output_Stream with private;

   --  Initialize the stream to write on the given streams.
   --  An internal buffer is allocated for writing the stream.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Output  : in Output_Stream_Access;
                         Size    : in Positive);

   --  Initialize the stream with a buffer of Size bytes.
   procedure Initialize (Stream  : in out Output_Buffer_Stream;
                         Size    : in Positive);

   --  Close the sink.
   overriding
   procedure Close (Stream : in out Output_Buffer_Stream);

   --  Get the direct access to the buffer.
   function Get_Buffer (Stream : in Output_Buffer_Stream) return Buffer_Access;

   --  Write the buffer array to the output stream.
   overriding
   procedure Write (Stream : in out Output_Buffer_Stream;
                    Buffer : in Ada.Streams.Stream_Element_Array);

   --  Flush the buffer by writing on the output stream.
   --  Raises Data_Error if there is no output stream.
   overriding
   procedure Flush (Stream : in out Output_Buffer_Stream);

   --  Flush the buffer in the <tt>Into</tt> array and return the index of the
   --  last element (inclusive) in <tt>Last</tt>.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Streams.Stream_Element_Array;
                    Last   : out Ada.Streams.Stream_Element_Offset);

   --  Flush the buffer stream to the unbounded string.
   procedure Flush (Stream : in out Output_Buffer_Stream;
                    Into   : out Ada.Strings.Unbounded.Unbounded_String);

   --  Get the number of element in the stream.
   function Get_Size (Stream : in Output_Buffer_Stream) return Natural;

   type Input_Buffer_Stream is limited new Input_Stream with private;

   --  Initialize the stream to read from the string.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Content : in String);

   --  Initialize the stream to read the given streams.
   procedure Initialize (Stream  : in out Input_Buffer_Stream;
                         Input   : in Input_Stream_Access;
                         Size    : in Positive);

   --  Fill the buffer by reading the input stream.
   --  Raises Data_Error if there is no input stream;
   procedure Fill (Stream : in out Input_Buffer_Stream);

   --  Read one character from the input stream.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Char   : out Character);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   overriding
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset);

   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   procedure Read (Stream : in out Input_Buffer_Stream;
                   Into   : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Returns True if the end of the stream is reached.
   function Is_Eof (Stream : in Input_Buffer_Stream) return Boolean;

private

   use Ada.Streams;

   type Output_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Output_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The output stream to use for flushing the buffer.
      Output      : Output_Stream_Access := null;

      No_Flush    : Boolean := False;
   end record;

   --  Flush the stream and release the buffer.
   overriding
   procedure Finalize (Object : in out Output_Buffer_Stream);

   type Input_Buffer_Stream is limited new Ada.Finalization.Limited_Controlled
     and Input_Stream with record
      --  The buffer where the data is written before being flushed.
      Buffer      : Buffer_Access := null;

      --  The next write position within the buffer.
      Write_Pos   : Stream_Element_Offset := 0;

      --  The next read position within the buffer.
      Read_Pos    : Stream_Element_Offset := 1;

      --  The last valid write position within the buffer.
      Last        : Stream_Element_Offset := 0;

      --  The input stream to use to fill the buffer.
      Input       : Input_Stream_Access := null;

      --  Reached end of file when reading.
      Eof         : Boolean := False;
   end record;

   --  Release the buffer.
   overriding
   procedure Finalize (Object : in out Input_Buffer_Stream);

end Util.Streams.Buffered;

Add some documentation

Add some documentation


-----------------------------------------------------------------------
--  awa-permissions -- Permissions module
--  Copyright (C) 2011, 2012, 2013, 2014, 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 Util.Log.Loggers;
with Util.Beans.Objects;
with Util.Serialize.Mappers.Record_Mapper;

with ADO.Schemas.Entities;
with ADO.Sessions.Entities;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Permissions.Controllers;
package body AWA.Permissions is

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

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index) is
   begin
      if not (Security.Contexts.Has_Permission (Permission)) then
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Identifier) is
      use type Security.Contexts.Security_Context_Access;

      Context : constant Security.Contexts.Security_Context_Access := Security.Contexts.Current;
      Perm    : Entity_Permission (Permission);
   begin
      if Context = null then
         Log.Debug ("Permission is refused because there is no security context");
         raise NO_PERMISSION;
      end if;
      Perm.Entity := Entity;
      if not Context.Has_Permission (Perm) then
         Log.Debug ("Permission is refused by the security controller");
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Objects.Object_Ref'Class) is
   begin
      if Entity.Is_Null then
         Log.Debug ("Permission is refused because the entity is null.");
         raise NO_PERMISSION;
      end if;
      Check (Permission, ADO.Objects.Get_Value (Entity.Get_Key));
   end Check;

   type Config_Fields is (FIELD_NAME, FIELD_ENTITY_TYPE, FIELD_ENTITY_PERMISSION, FIELD_SQL);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <entity-type>, <sql> and
   --  <entity-permission> XML entities are found.  Create the new permission when the complete
   --  permission definition has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use AWA.Permissions.Controllers;
      use type ADO.Entity_Type;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_SQL =>
            Into.SQL := Value;

         when FIELD_ENTITY_TYPE =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Into.Count = MAX_ENTITY_TYPES then
                  raise Util.Serialize.Mappers.Field_Error with "Too many entity types.";
               end if;
               Into.Count := Into.Count + 1;
               Into.Entities (Into.Count)
                 := ADO.Sessions.Entities.Find_Entity_Type (Into.Session, Name);

            exception
               when ADO.Schemas.Entities.No_Entity_Type =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Name;
            end;

         when FIELD_ENTITY_PERMISSION =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               if Into.Count = 0 then
                  raise Util.Serialize.Mappers.Field_Error
                  with "Permission '" & Name & "' ignored: missing entity type";
               end if;
               declare
                  SQL  : constant String := Util.Beans.Objects.To_String (Into.SQL);
                  Perm : constant Entity_Controller_Access
                    := new Entity_Controller '(Len      => SQL'Length,
                                               SQL      => SQL,
                                               Entities => Into.Entities);
               begin
                  Into.Manager.Add_Permission (Name, Perm.all'Access);
                  Into.Count := 0;
                  Into.Entities := (others => ADO.NO_ENTITY_TYPE);
               end;
            end;

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the entity-permission description.  For example:
   --
   --  <entity-permission>
   --     <name>create-workspace</name>
   --     <entity-type>WORKSPACE</entity-type>
   --     <sql>select acl.id from acl where ...</sql>
   --  </entity-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  SQL statement returns a non empty list.
   --  ------------------------------

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Entity_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out Entity_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : constant Controller_Config_Access := Policy.Config'Unchecked_Access;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config.Session := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("entity-permission", FIELD_ENTITY_PERMISSION);
   Mapper.Add_Mapping ("entity-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("entity-permission/entity-type", FIELD_ENTITY_TYPE);
   Mapper.Add_Mapping ("entity-permission/sql", FIELD_SQL);
end AWA.Permissions;

-----------------------------------------------------------------------
--  awa-permissions -- Permissions module
--  Copyright (C) 2011, 2012, 2013, 2014, 2016, 2017 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.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with ADO.Schemas.Entities;
with ADO.Sessions.Entities;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Permissions.Controllers;
package body AWA.Permissions is

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

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index) is
   begin
      if not (Security.Contexts.Has_Permission (Permission)) then
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Identifier) is
      use type Security.Contexts.Security_Context_Access;

      Context : constant Security.Contexts.Security_Context_Access := Security.Contexts.Current;
      Perm    : Entity_Permission (Permission);
   begin
      if Context = null then
         Log.Debug ("Permission is refused because there is no security context");
         raise NO_PERMISSION;
      end if;
      Perm.Entity := Entity;
      if not Context.Has_Permission (Perm) then
         Log.Debug ("Permission is refused by the security controller");
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Objects.Object_Ref'Class) is
   begin
      if Entity.Is_Null then
         Log.Debug ("Permission is refused because the entity is null.");
         raise NO_PERMISSION;
      end if;
      Check (Permission, ADO.Objects.Get_Value (Entity.Get_Key));
   end Check;

   type Config_Fields is (FIELD_NAME, FIELD_ENTITY_TYPE, FIELD_ENTITY_PERMISSION, FIELD_SQL);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <entity-type>, <sql> and
   --  <entity-permission> XML entities are found.  Create the new permission when the complete
   --  permission definition has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use AWA.Permissions.Controllers;
      use type ADO.Entity_Type;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_SQL =>
            Into.SQL := Value;

         when FIELD_ENTITY_TYPE =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Into.Count = MAX_ENTITY_TYPES then
                  raise Util.Serialize.Mappers.Field_Error with "Too many entity types.";
               end if;
               Into.Count := Into.Count + 1;
               Into.Entities (Into.Count)
                 := ADO.Sessions.Entities.Find_Entity_Type (Into.Session, Name);

            exception
               when ADO.Schemas.Entities.No_Entity_Type =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Name;
            end;

         when FIELD_ENTITY_PERMISSION =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               if Into.Count = 0 then
                  raise Util.Serialize.Mappers.Field_Error
                  with "Permission '" & Name & "' ignored: missing entity type";
               end if;
               declare
                  SQL  : constant String := Util.Beans.Objects.To_String (Into.SQL);
                  Perm : constant Entity_Controller_Access
                    := new Entity_Controller '(Len      => SQL'Length,
                                               SQL      => SQL,
                                               Entities => Into.Entities);
               begin
                  Into.Manager.Add_Permission (Name, Perm.all'Access);
                  Into.Count := 0;
                  Into.Entities := (others => ADO.NO_ENTITY_TYPE);
               end;
            end;

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the entity-permission description.  For example:
   --
   --  <entity-permission>
   --     <name>create-workspace</name>
   --     <entity-type>WORKSPACE</entity-type>
   --     <sql>select acl.id from acl where ...</sql>
   --  </entity-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  SQL statement returns a non empty list.
   --  ------------------------------

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Entity_Policy) return String is
      pragma Unreferenced (From);
   begin
      return NAME;
   end Get_Name;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out Entity_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : constant Controller_Config_Access := Policy.Config'Unchecked_Access;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config.Session := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("entity-permission", FIELD_ENTITY_PERMISSION);
   Mapper.Add_Mapping ("entity-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("entity-permission/entity-type", FIELD_ENTITY_TYPE);
   Mapper.Add_Mapping ("entity-permission/sql", FIELD_SQL);
end AWA.Permissions;

Fix compilation warnings

Fix compilation warnings


-----------------------------------------------------------------------
--  awa-events-services -- AWA Event Manager
--  Copyright (C) 2012, 2015, 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.Unchecked_Deallocation;

with Util.Log.Loggers;

with ADO.SQL;
with ADO.Sessions;

with AWA.Events.Dispatchers.Tasks;
with AWA.Events.Dispatchers.Actions;
package body AWA.Events.Services is

   use type Util.Strings.Name_Access;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Events.Services");

   --  ------------------------------
   --  Send the event to the modules that subscribed to it.
   --  The event is sent on each event queue.  Event queues will dispatch the event
   --  by invoking immediately or later on the Dispatch operation.  The synchronous
   --  or asynchronous reception of the event depends on the event queue.
   --  ------------------------------
   procedure Send (Manager : in Event_Manager;
                   Event   : in Module_Event'Class) is
      procedure Send_Queue (Queue : in Queue_Dispatcher);

      procedure Send_Queue (Queue : in Queue_Dispatcher) is
      begin
         if Queue.Queue.Is_Null then
            Queue.Dispatcher.Dispatch (Event);
         else
            Queue.Queue.Enqueue (Event);
         end if;
      end Send_Queue;

      Name : constant Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      --  Find the event queues associated with the event.  Post the event on each queue.
      --  Some queue can dispatch the event immediately while some others may dispatched it
      --  asynchronously.
      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Sending event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Sending event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Send_Queue'Access);
               Queue_Dispatcher_Lists.Next (Pos);
               exit when not Queue_Dispatcher_Lists.Has_Element (Pos);
            end loop;
         end if;
      end;
   end Send;

   --  ------------------------------
   --  Set the event message type which correspond to the <tt>Kind</tt> event index.
   --  ------------------------------
   procedure Set_Message_Type (Manager : in Event_Manager;
                               Event   : in out AWA.Events.Models.Message_Ref;
                               Kind    : in Event_Index) is
   begin
      if not Event_Arrays.Is_Valid (Kind) then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Kind));
         raise Not_Found;
      end if;
      Event.Set_Status (AWA.Events.Models.QUEUED);
      Event.Set_Message_Type (Manager.Actions (Kind).Event);
   end Set_Message_Type;

   --  ------------------------------
   --  Set the event queue associated with the event message.  The event queue identified by
   --  <tt>Name</tt> is searched to find the <tt>Queue_Ref</tt> instance.
   --  ------------------------------
   procedure Set_Event_Queue (Manager : in Event_Manager;
                              Event   : in out AWA.Events.Models.Message_Ref;
                              Name    : in String) is
      Queue : constant AWA.Events.Queues.Queue_Ref := Manager.Find_Queue (Name);
   begin
      Event.Set_Queue (Queue.Get_Queue);
   end Set_Event_Queue;

   --  ------------------------------
   --  Dispatch the event identified by Event and associated with the event
   --  queue Queue.  The event actions which are associated with the event are
   --  executed synchronously.
   --  ------------------------------
   procedure Dispatch (Manager : in Event_Manager;
                       Queue   : in AWA.Events.Queues.Queue_Ref;
                       Event   : in Module_Event'Class) is
      procedure Find_Queue (List : in Queue_Dispatcher);

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         if List.Queue = Queue then
            List.Dispatcher.Dispatch (Event);
            Found := True;
         end if;
      end Find_Queue;

      Name : constant Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot dispatch event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Dispatching event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Dispatching event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
               exit when Found;
               Queue_Dispatcher_Lists.Next (Pos);
               if not Queue_Dispatcher_Lists.Has_Element (Pos) then
                  Log.Debug ("Dispatched event {0} but there was no listener", Name.all);
                  exit;
               end if;
            end loop;
         end if;
      end;
   end Dispatch;

   --  ------------------------------
   --  Find the event queue identified by the given name.
   --  ------------------------------
   function Find_Queue (Manager : in Event_Manager;
                        Name    : in String) return AWA.Events.Queues.Queue_Ref is
      Pos : constant Queues.Maps.Cursor := Manager.Queues.Find (Name);
   begin
      if Queues.Maps.Has_Element (Pos) then
         return Queues.Maps.Element (Pos);
      else
         Log.Error ("Event queue {0} not found", Name);
         return AWA.Events.Queues.Null_Queue;
      end if;
   end Find_Queue;

   --  ------------------------------
   --  Add the event queue in the registry.
   --  ------------------------------
   procedure Add_Queue (Manager : in out Event_Manager;
                        Queue   : in AWA.Events.Queues.Queue_Ref) is
      Name : constant String := Queue.Get_Name;
   begin
      if Manager.Queues.Contains (Name) then
         Log.Error ("Event queue {0} already defined");
      else
         Log.Info ("Adding event queue {0}", Name);
      end if;
      Manager.Queues.Include (Key      => Name,
                              New_Item => Queue);
   end Add_Queue;

   --  ------------------------------
   --  Add an action invoked when the event identified by Event is sent.
   --  The event is posted on the queue identified by Queue.
   --  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 Event_Manager;
                         Event   : in String;
                         Queue   : in AWA.Events.Queues.Queue_Ref;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is
      procedure Find_Queue (List : in Queue_Dispatcher);
      procedure Add_Action (List : in out Queue_Dispatcher);

      procedure Add_Action (List : in out Queue_Dispatcher) is
         use type AWA.Events.Dispatchers.Dispatcher_Access;
      begin
         if List.Dispatcher = null then
            List.Dispatcher := AWA.Events.Dispatchers.Actions.Create_Dispatcher
              (Application => Manager.Application.all'Access);
         end if;
         List.Dispatcher.Add_Action (Action, Params);
      end Add_Action;

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         Found := List.Queue = Queue;
      end Find_Queue;

      Index : constant Event_Index := Find_Event_Index (Event);
      Pos   : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Index).Queues.First;
   begin
      Log.Info ("Adding action {0} to event {1}", Action.Get_Expression, Event);

      --  Find the queue.
      while Queue_Dispatcher_Lists.Has_Element (Pos) loop
         Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
         exit when Found;
         Queue_Dispatcher_Lists.Next (Pos);
      end loop;

      --  Create it if it does not exist.
      if not Found then
         declare
            New_Queue : Queue_Dispatcher;
         begin
            New_Queue.Queue := Queue;
            Manager.Actions (Index).Queues.Append (New_Queue);
            Pos := Manager.Actions (Index).Queues.Last;
         end;
      end if;

      --  And append the new action to the event queue.
      Manager.Actions (Index).Queues.Update_Element (Pos, Add_Action'Access);
   end Add_Action;

   --  ------------------------------
   --  Add a dispatcher to process the event queues matching the Match string.
   --  The dispatcher can create up to Count tasks running at the priority Priority.
   --  ------------------------------
   procedure Add_Dispatcher (Manager  : in out Event_Manager;
                             Match    : in String;
                             Count    : in Positive;
                             Priority : in Positive) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;
   begin
      Log.Info ("Adding event dispatcher with {0} tasks prio {1} and dispatching queues '{2}'",
                Positive'Image (Count), Positive'Image (Priority), Match);

      for I in Manager.Dispatchers'Range loop
         if Manager.Dispatchers (I) = null then
            Manager.Dispatchers (I) :=
              AWA.Events.Dispatchers.Tasks.Create_Dispatcher (Manager'Unchecked_Access,
                                                              Match, Count, Priority);
            return;
         end if;
      end loop;
      Log.Error ("Implementation limit is reached.  Too many dispatcher.");
   end Add_Dispatcher;

   --  ------------------------------
   --  Initialize the event manager.
   --  ------------------------------
   procedure Initialize (Manager : in out Event_Manager;
                         App     : in Application_Access) is
      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref);

      Msg_Types : AWA.Events.Models.Message_Type_Vector;

      Query     : ADO.SQL.Query;

      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref) is
         Name : constant String := Msg.Get_Name;
      begin
         declare
            Index : constant Event_Index := Find_Event_Index (Name);
         begin
            Manager.Actions (Index).Event := Msg;
         end;

      exception
         when others =>
            Log.Warn ("Event {0} is no longer used", Name);
      end Set_Events;

      DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
   begin
      Log.Info ("Initializing {0} events", Event_Index'Image (Event_Arrays.Get_Last));

      Manager.Application := App;
      DB.Begin_Transaction;
      Manager.Actions := new Event_Queues_Array (1 .. Event_Arrays.Get_Last);

      AWA.Events.Models.List (Object  => Msg_Types,
                              Session => DB,
                              Query   => Query);
      declare
         Pos : AWA.Events.Models.Message_Type_Vectors.Cursor := Msg_Types.First;
      begin
         while AWA.Events.Models.Message_Type_Vectors.Has_Element (Pos) loop
            AWA.Events.Models.Message_Type_Vectors.Query_Element (Pos, Set_Events'Access);
            AWA.Events.Models.Message_Type_Vectors.Next (Pos);
         end loop;
      end;

      for I in Manager.Actions'Range loop
         if Manager.Actions (I).Event.Is_Null then
            declare
               Name : constant Name_Access := Get_Event_Type_Name (I);
            begin
               Log.Info ("Creating event type {0} in database", Name.all);
               Manager.Actions (I).Event.Set_Name (Name.all);
               Manager.Actions (I).Event.Save (DB);
            end;
         end if;
      end loop;
      DB.Commit;
   end Initialize;

   --  ------------------------------
   --  Start the event manager.  The dispatchers are configured to dispatch the event queues
   --  and tasks are started to process asynchronous events.
   --  ------------------------------
   procedure Start (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref);

      --  ------------------------------
      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      --  ------------------------------
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref) is
         pragma Unreferenced (Key);

         Added : Boolean := False;
      begin
         for I in reverse Manager.Dispatchers'Range loop
            if Manager.Dispatchers (I) /= null then
               Manager.Dispatchers (I).Add_Queue (Queue, Added);
               exit when Added;
            end if;
         end loop;
      end Associate_Dispatcher;

      Iter : AWA.Events.Queues.Maps.Cursor := Manager.Queues.First;
   begin
      Log.Info ("Starting the event manager");

      while AWA.Events.Queues.Maps.Has_Element (Iter) loop
         Manager.Queues.Update_Element (Iter, Associate_Dispatcher'Access);
         AWA.Events.Queues.Maps.Next (Iter);
      end loop;

      --  Start the dispatchers.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Manager.Dispatchers (I).Start;
      end loop;
   end Start;

   --  ------------------------------
   --  Stop the event manager.
   --  ------------------------------
   procedure Stop (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;
   begin
      Log.Info ("Stopping the event manager");

      --  Stop the dispatchers.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Manager.Dispatchers (I).Stop;
      end loop;
   end Stop;

   --  ------------------------------
   --  Get the application associated with the event manager.
   --  ------------------------------
   function Get_Application (Manager : in Event_Manager) return Application_Access is
   begin
      return Manager.Application;
   end Get_Application;

   --  ------------------------------
   --  Finalize the queue dispatcher releasing the dispatcher memory.
   --  ------------------------------
   procedure Finalize (Object : in out Queue_Dispatcher) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      Free (Object.Dispatcher);
   end Finalize;

   --  ------------------------------
   --  Finalize the event queues and the dispatchers.
   --  ------------------------------
   procedure Finalize (Object : in out Event_Queues) is
   begin
      loop
         declare
            Pos : constant Queue_Dispatcher_Lists.Cursor := Object.Queues.First;
         begin
            exit when not Queue_Dispatcher_Lists.Has_Element (Pos);

            Object.Queues.Update_Element (Position => Pos,
                                          Process  => Finalize'Access);
            Object.Queues.Delete_First;
         end;
      end loop;
   end Finalize;

   --  ------------------------------
   --  Finalize the event manager by releasing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Event_Queues_Array,
                                        Name   => Event_Queues_Array_Access);
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      --  Stop the dispatcher first.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Free (Manager.Dispatchers (I));
      end loop;
      if Manager.Actions /= null then
         for I in Manager.Actions'Range loop
            Finalize (Manager.Actions (I));
         end loop;
         Free (Manager.Actions);
      end if;
   end Finalize;

end AWA.Events.Services;

-----------------------------------------------------------------------
--  awa-events-services -- AWA Event Manager
--  Copyright (C) 2012, 2015, 2016, 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.
-----------------------------------------------------------------------

with Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with ADO.SQL;
with ADO.Sessions;

with AWA.Events.Dispatchers.Tasks;
with AWA.Events.Dispatchers.Actions;
package body AWA.Events.Services is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Events.Services");

   --  ------------------------------
   --  Send the event to the modules that subscribed to it.
   --  The event is sent on each event queue.  Event queues will dispatch the event
   --  by invoking immediately or later on the Dispatch operation.  The synchronous
   --  or asynchronous reception of the event depends on the event queue.
   --  ------------------------------
   procedure Send (Manager : in Event_Manager;
                   Event   : in Module_Event'Class) is
      procedure Send_Queue (Queue : in Queue_Dispatcher);

      procedure Send_Queue (Queue : in Queue_Dispatcher) is
      begin
         if Queue.Queue.Is_Null then
            Queue.Dispatcher.Dispatch (Event);
         else
            Queue.Queue.Enqueue (Event);
         end if;
      end Send_Queue;

      Name : constant Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      --  Find the event queues associated with the event.  Post the event on each queue.
      --  Some queue can dispatch the event immediately while some others may dispatched it
      --  asynchronously.
      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Sending event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Sending event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Send_Queue'Access);
               Queue_Dispatcher_Lists.Next (Pos);
               exit when not Queue_Dispatcher_Lists.Has_Element (Pos);
            end loop;
         end if;
      end;
   end Send;

   --  ------------------------------
   --  Set the event message type which correspond to the <tt>Kind</tt> event index.
   --  ------------------------------
   procedure Set_Message_Type (Manager : in Event_Manager;
                               Event   : in out AWA.Events.Models.Message_Ref;
                               Kind    : in Event_Index) is
   begin
      if not Event_Arrays.Is_Valid (Kind) then
         Log.Error ("Cannot send event type {0}", Event_Index'Image (Kind));
         raise Not_Found;
      end if;
      Event.Set_Status (AWA.Events.Models.QUEUED);
      Event.Set_Message_Type (Manager.Actions (Kind).Event);
   end Set_Message_Type;

   --  ------------------------------
   --  Set the event queue associated with the event message.  The event queue identified by
   --  <tt>Name</tt> is searched to find the <tt>Queue_Ref</tt> instance.
   --  ------------------------------
   procedure Set_Event_Queue (Manager : in Event_Manager;
                              Event   : in out AWA.Events.Models.Message_Ref;
                              Name    : in String) is
      Queue : constant AWA.Events.Queues.Queue_Ref := Manager.Find_Queue (Name);
   begin
      Event.Set_Queue (Queue.Get_Queue);
   end Set_Event_Queue;

   --  ------------------------------
   --  Dispatch the event identified by Event and associated with the event
   --  queue Queue.  The event actions which are associated with the event are
   --  executed synchronously.
   --  ------------------------------
   procedure Dispatch (Manager : in Event_Manager;
                       Queue   : in AWA.Events.Queues.Queue_Ref;
                       Event   : in Module_Event'Class) is
      procedure Find_Queue (List : in Queue_Dispatcher);

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         if List.Queue = Queue then
            List.Dispatcher.Dispatch (Event);
            Found := True;
         end if;
      end Find_Queue;

      Name : constant Name_Access := Get_Event_Type_Name (Event.Kind);
   begin
      if Name = null then
         Log.Error ("Cannot dispatch event type {0}", Event_Index'Image (Event.Kind));
         raise Not_Found;
      end if;

      declare
         Pos  : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Event.Kind).Queues.First;
      begin
         if not Queue_Dispatcher_Lists.Has_Element (Pos) then
            Log.Debug ("Dispatching event {0} but there is no listener", Name.all);
         else
            Log.Debug ("Dispatching event {0}", Name.all);
            loop
               Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
               exit when Found;
               Queue_Dispatcher_Lists.Next (Pos);
               if not Queue_Dispatcher_Lists.Has_Element (Pos) then
                  Log.Debug ("Dispatched event {0} but there was no listener", Name.all);
                  exit;
               end if;
            end loop;
         end if;
      end;
   end Dispatch;

   --  ------------------------------
   --  Find the event queue identified by the given name.
   --  ------------------------------
   function Find_Queue (Manager : in Event_Manager;
                        Name    : in String) return AWA.Events.Queues.Queue_Ref is
      Pos : constant Queues.Maps.Cursor := Manager.Queues.Find (Name);
   begin
      if Queues.Maps.Has_Element (Pos) then
         return Queues.Maps.Element (Pos);
      else
         Log.Error ("Event queue {0} not found", Name);
         return AWA.Events.Queues.Null_Queue;
      end if;
   end Find_Queue;

   --  ------------------------------
   --  Add the event queue in the registry.
   --  ------------------------------
   procedure Add_Queue (Manager : in out Event_Manager;
                        Queue   : in AWA.Events.Queues.Queue_Ref) is
      Name : constant String := Queue.Get_Name;
   begin
      if Manager.Queues.Contains (Name) then
         Log.Error ("Event queue {0} already defined");
      else
         Log.Info ("Adding event queue {0}", Name);
      end if;
      Manager.Queues.Include (Key      => Name,
                              New_Item => Queue);
   end Add_Queue;

   --  ------------------------------
   --  Add an action invoked when the event identified by Event is sent.
   --  The event is posted on the queue identified by Queue.
   --  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 Event_Manager;
                         Event   : in String;
                         Queue   : in AWA.Events.Queues.Queue_Ref;
                         Action  : in EL.Expressions.Method_Expression;
                         Params  : in EL.Beans.Param_Vectors.Vector) is
      procedure Find_Queue (List : in Queue_Dispatcher);
      procedure Add_Action (List : in out Queue_Dispatcher);

      procedure Add_Action (List : in out Queue_Dispatcher) is
         use type AWA.Events.Dispatchers.Dispatcher_Access;
      begin
         if List.Dispatcher = null then
            List.Dispatcher := AWA.Events.Dispatchers.Actions.Create_Dispatcher
              (Application => Manager.Application.all'Access);
         end if;
         List.Dispatcher.Add_Action (Action, Params);
      end Add_Action;

      Found : Boolean := False;

      procedure Find_Queue (List : in Queue_Dispatcher) is
      begin
         Found := List.Queue = Queue;
      end Find_Queue;

      Index : constant Event_Index := Find_Event_Index (Event);
      Pos   : Queue_Dispatcher_Lists.Cursor := Manager.Actions (Index).Queues.First;
   begin
      Log.Info ("Adding action {0} to event {1}", Action.Get_Expression, Event);

      --  Find the queue.
      while Queue_Dispatcher_Lists.Has_Element (Pos) loop
         Queue_Dispatcher_Lists.Query_Element (Pos, Find_Queue'Access);
         exit when Found;
         Queue_Dispatcher_Lists.Next (Pos);
      end loop;

      --  Create it if it does not exist.
      if not Found then
         declare
            New_Queue : Queue_Dispatcher;
         begin
            New_Queue.Queue := Queue;
            Manager.Actions (Index).Queues.Append (New_Queue);
            Pos := Manager.Actions (Index).Queues.Last;
         end;
      end if;

      --  And append the new action to the event queue.
      Manager.Actions (Index).Queues.Update_Element (Pos, Add_Action'Access);
   end Add_Action;

   --  ------------------------------
   --  Add a dispatcher to process the event queues matching the Match string.
   --  The dispatcher can create up to Count tasks running at the priority Priority.
   --  ------------------------------
   procedure Add_Dispatcher (Manager  : in out Event_Manager;
                             Match    : in String;
                             Count    : in Positive;
                             Priority : in Positive) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;
   begin
      Log.Info ("Adding event dispatcher with {0} tasks prio {1} and dispatching queues '{2}'",
                Positive'Image (Count), Positive'Image (Priority), Match);

      for I in Manager.Dispatchers'Range loop
         if Manager.Dispatchers (I) = null then
            Manager.Dispatchers (I) :=
              AWA.Events.Dispatchers.Tasks.Create_Dispatcher (Manager'Unchecked_Access,
                                                              Match, Count, Priority);
            return;
         end if;
      end loop;
      Log.Error ("Implementation limit is reached.  Too many dispatcher.");
   end Add_Dispatcher;

   --  ------------------------------
   --  Initialize the event manager.
   --  ------------------------------
   procedure Initialize (Manager : in out Event_Manager;
                         App     : in Application_Access) is
      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref);

      Msg_Types : AWA.Events.Models.Message_Type_Vector;

      Query     : ADO.SQL.Query;

      procedure Set_Events (Msg : in AWA.Events.Models.Message_Type_Ref) is
         Name : constant String := Msg.Get_Name;
      begin
         declare
            Index : constant Event_Index := Find_Event_Index (Name);
         begin
            Manager.Actions (Index).Event := Msg;
         end;

      exception
         when others =>
            Log.Warn ("Event {0} is no longer used", Name);
      end Set_Events;

      DB : ADO.Sessions.Master_Session := App.Get_Master_Session;
   begin
      Log.Info ("Initializing {0} events", Event_Index'Image (Event_Arrays.Get_Last));

      Manager.Application := App;
      DB.Begin_Transaction;
      Manager.Actions := new Event_Queues_Array (1 .. Event_Arrays.Get_Last);

      AWA.Events.Models.List (Object  => Msg_Types,
                              Session => DB,
                              Query   => Query);
      declare
         Pos : AWA.Events.Models.Message_Type_Vectors.Cursor := Msg_Types.First;
      begin
         while AWA.Events.Models.Message_Type_Vectors.Has_Element (Pos) loop
            AWA.Events.Models.Message_Type_Vectors.Query_Element (Pos, Set_Events'Access);
            AWA.Events.Models.Message_Type_Vectors.Next (Pos);
         end loop;
      end;

      for I in Manager.Actions'Range loop
         if Manager.Actions (I).Event.Is_Null then
            declare
               Name : constant Name_Access := Get_Event_Type_Name (I);
            begin
               Log.Info ("Creating event type {0} in database", Name.all);
               Manager.Actions (I).Event.Set_Name (Name.all);
               Manager.Actions (I).Event.Save (DB);
            end;
         end if;
      end loop;
      DB.Commit;
   end Initialize;

   --  ------------------------------
   --  Start the event manager.  The dispatchers are configured to dispatch the event queues
   --  and tasks are started to process asynchronous events.
   --  ------------------------------
   procedure Start (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref);

      --  ------------------------------
      --  Dispatch the event queues to the dispatcher according to the dispatcher configuration.
      --  ------------------------------
      procedure Associate_Dispatcher (Key   : in String;
                                      Queue : in out AWA.Events.Queues.Queue_Ref) is
         pragma Unreferenced (Key);

         Added : Boolean := False;
      begin
         for I in reverse Manager.Dispatchers'Range loop
            if Manager.Dispatchers (I) /= null then
               Manager.Dispatchers (I).Add_Queue (Queue, Added);
               exit when Added;
            end if;
         end loop;
      end Associate_Dispatcher;

      Iter : AWA.Events.Queues.Maps.Cursor := Manager.Queues.First;
   begin
      Log.Info ("Starting the event manager");

      while AWA.Events.Queues.Maps.Has_Element (Iter) loop
         Manager.Queues.Update_Element (Iter, Associate_Dispatcher'Access);
         AWA.Events.Queues.Maps.Next (Iter);
      end loop;

      --  Start the dispatchers.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Manager.Dispatchers (I).Start;
      end loop;
   end Start;

   --  ------------------------------
   --  Stop the event manager.
   --  ------------------------------
   procedure Stop (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;
   begin
      Log.Info ("Stopping the event manager");

      --  Stop the dispatchers.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Manager.Dispatchers (I).Stop;
      end loop;
   end Stop;

   --  ------------------------------
   --  Get the application associated with the event manager.
   --  ------------------------------
   function Get_Application (Manager : in Event_Manager) return Application_Access is
   begin
      return Manager.Application;
   end Get_Application;

   --  ------------------------------
   --  Finalize the queue dispatcher releasing the dispatcher memory.
   --  ------------------------------
   procedure Finalize (Object : in out Queue_Dispatcher) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      Free (Object.Dispatcher);
   end Finalize;

   --  ------------------------------
   --  Finalize the event queues and the dispatchers.
   --  ------------------------------
   procedure Finalize (Object : in out Event_Queues) is
   begin
      loop
         declare
            Pos : constant Queue_Dispatcher_Lists.Cursor := Object.Queues.First;
         begin
            exit when not Queue_Dispatcher_Lists.Has_Element (Pos);

            Object.Queues.Update_Element (Position => Pos,
                                          Process  => Finalize'Access);
            Object.Queues.Delete_First;
         end;
      end loop;
   end Finalize;

   --  ------------------------------
   --  Finalize the event manager by releasing the allocated storage.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Event_Manager) is
      use type AWA.Events.Dispatchers.Dispatcher_Access;

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Event_Queues_Array,
                                        Name   => Event_Queues_Array_Access);
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => AWA.Events.Dispatchers.Dispatcher'Class,
                                         Name   => AWA.Events.Dispatchers.Dispatcher_Access);
   begin
      --  Stop the dispatcher first.
      for I in Manager.Dispatchers'Range loop
         exit when Manager.Dispatchers (I) = null;
         Free (Manager.Dispatchers (I));
      end loop;
      if Manager.Actions /= null then
         for I in Manager.Actions'Range loop
            Finalize (Manager.Actions (I));
         end loop;
         Free (Manager.Actions);
      end if;
   end Finalize;

end AWA.Events.Services;

Remove unused use clause to fix compilation warning