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

with Util.Log;
with Util.Log.Loggers;
with Ada.Unchecked_Deallocation;

with ADO.Drivers;
with ADO.Sequences;
package body ADO.Sessions is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Sessions");

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "") is
   begin
      if Database.Impl = null then
         Log.Error ("Session is closed or not initialized");
         raise NOT_OPEN;
      end if;
      if Message'Length > 0 then
         Log.Info (Message, Database.Impl.Database.Get_Ident);
      end if;
   end Check_Session;

   --  ---------
   --  Session
   --  ---------

   --  ------------------------------
   --  Get the session status.
   --  ------------------------------
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status is
   begin
      if Database.Impl = null then
         return ADO.Databases.CLOSED;
      end if;
      return Database.Impl.Database.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Close the session.
   --  ------------------------------
   procedure Close (Database : in out Session) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Session_Record,
                                    Name   => Session_Record_Access);

      Is_Zero : Boolean;
   begin
      Log.Info ("Closing session");
      if Database.Impl /= null then
         ADO.Objects.Release_Proxy (Database.Impl.Proxy);
         Database.Impl.Database.Close;
         Util.Concurrent.Counters.Decrement (Database.Impl.Counter, Is_Zero);
         if Is_Zero then
            Free (Database.Impl);
         end if;
         Database.Impl := null;
      end if;
   end Close;

   --  ------------------------------
   --  Get the database connection.
   --  ------------------------------
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class is
   begin
      Check_Session (Database);
      return Database.Impl.Database;
   end Get_Connection;

   --  ------------------------------
   --  Attach the object to the session.
   --  ------------------------------
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class) is
      pragma Unreferenced (Object);
   begin
      Check_Session (Database);
   end Attach;

   --  ------------------------------
   --  Check if the session contains the object identified by the given key.
   --  ------------------------------
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean is
   begin
      Check_Session (Database);
      return ADO.Objects.Cache.Contains (Database.Impl.Cache, Item);
   end Contains;

   --  ------------------------------
   --  Remove the object from the session cache.
   --  ------------------------------
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key) is
   begin
      Check_Session (Database);
      ADO.Objects.Cache.Remove (Database.Impl.Cache, Item);
   end Evict;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         SQL  : constant String := Query.Get_SQL (Database.Impl.Database.Get_Driver_Index);
         Stmt : Query_Statement := Database.Impl.Database.Create_Statement (SQL);
      begin
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement and initialize the SQL statement with the query definition.
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Index : constant ADO.Drivers.Driver_Index := Database.Impl.Database.Get_Driver_Index;
         SQL   : constant String := ADO.Queries.Get_SQL (Query, Index);
      begin
         return Database.Impl.Database.Create_Statement (SQL);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : Query_Statement := Database.Impl.Database.Create_Statement (Table);
      begin
         if Query in ADO.Queries.Context'Class then
            declare
               Pos : constant ADO.Drivers.Driver_Index := Database.Impl.Database.Get_Driver_Index;
               SQL : constant String := ADO.Queries.Context'Class (Query).Get_SQL (Pos);
            begin
               ADO.SQL.Append (Stmt.Get_Query.SQL, SQL);
            end;
         end if;
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ---------
   --  Master Session
   --  ---------

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Begin transaction {0}");
      Database.Impl.Database.Begin_Transaction;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Commit transaction {0}");
      Database.Impl.Database.Commit;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Rollback transaction {0}");
      Database.Impl.Database.Rollback;
   end Rollback;

   --  ------------------------------
   --  Allocate an identifier for the table.
   --  ------------------------------
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class) is
   begin
      Check_Session (Database);
      ADO.Sequences.Allocate (Database.Sequences.all, Id);
   end Allocate;

   --  ------------------------------
   --  Flush the objects that were modified.
   --  ------------------------------
   procedure Flush (Database : in out Master_Session) is
   begin
      Check_Session (Database);
   end Flush;

   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Counter);
      end if;
   end Adjust;

   overriding
   procedure Finalize (Object : in out Session) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Session_Record,
                                         Name   => Session_Record_Access);
      Is_Zero : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Counter, Is_Zero);
         if Is_Zero then
            ADO.Objects.Release_Proxy (Object.Impl.Proxy);
            Object.Impl.Database.Close;
            Free (Object.Impl);
         end if;
         Object.Impl := null;
      end if;
   end Finalize;

   --  ------------------------------
   --  Create a delete statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   --  ------------------------------
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access is
      use type ADO.Objects.Session_Proxy_Access;
   begin
      Check_Session (Database);
      if Database.Impl.Proxy = null then
         Database.Impl.Proxy := ADO.Objects.Create_Session_Proxy (Database.Impl);
      end if;
      return Database.Impl.Proxy;
   end Get_Session_Proxy;

end ADO.Sessions;

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

with Util.Log;
with Util.Log.Loggers;
with Ada.Unchecked_Deallocation;

with ADO.Drivers;
with ADO.Sequences;
package body ADO.Sessions is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ADO.Sessions");

   procedure Check_Session (Database : in Session'Class;
                            Message  : in String := "") is
   begin
      if Database.Impl = null then
         Log.Error ("Session is closed or not initialized");
         raise NOT_OPEN;
      end if;
      if Message'Length > 0 then
         Log.Info (Message, Database.Impl.Database.Get_Ident);
      end if;
   end Check_Session;

   --  ---------
   --  Session
   --  ---------

   --  ------------------------------
   --  Get the session status.
   --  ------------------------------
   function Get_Status (Database : in Session) return ADO.Databases.Connection_Status is
   begin
      if Database.Impl = null then
         return ADO.Databases.CLOSED;
      end if;
      return Database.Impl.Database.Get_Status;
   end Get_Status;

   --  ------------------------------
   --  Close the session.
   --  ------------------------------
   procedure Close (Database : in out Session) is

      procedure Free is new
        Ada.Unchecked_Deallocation (Object => Session_Record,
                                    Name   => Session_Record_Access);

      Is_Zero : Boolean;
   begin
      Log.Info ("Closing session");
      if Database.Impl /= null then
         ADO.Objects.Release_Proxy (Database.Impl.Proxy);
         Database.Impl.Database.Close;
         Util.Concurrent.Counters.Decrement (Database.Impl.Counter, Is_Zero);
         if Is_Zero then
            Free (Database.Impl);
         end if;
         Database.Impl := null;
      end if;
   end Close;

   --  ------------------------------
   --  Get the database connection.
   --  ------------------------------
   function Get_Connection (Database : in Session) return ADO.Databases.Connection'Class is
   begin
      Check_Session (Database);
      return Database.Impl.Database;
   end Get_Connection;

   --  ------------------------------
   --  Attach the object to the session.
   --  ------------------------------
   procedure Attach (Database : in out Session;
                     Object   : in ADO.Objects.Object_Ref'Class) is
      pragma Unreferenced (Object);
   begin
      Check_Session (Database);
   end Attach;

   --  ------------------------------
   --  Check if the session contains the object identified by the given key.
   --  ------------------------------
   function Contains (Database : in Session;
                      Item     : in ADO.Objects.Object_Key) return Boolean is
   begin
      Check_Session (Database);
      return ADO.Objects.Cache.Contains (Database.Impl.Cache, Item);
   end Contains;

   --  ------------------------------
   --  Remove the object from the session cache.
   --  ------------------------------
   procedure Evict (Database : in out Session;
                    Item     : in ADO.Objects.Object_Key) is
   begin
      Check_Session (Database);
      ADO.Objects.Cache.Remove (Database.Impl.Cache, Item);
   end Evict;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Query);
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Context'Class)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         SQL  : constant String := Query.Get_SQL (Database.Impl.Database.Get_Driver_Index);
         Stmt : Query_Statement := Database.Impl.Database.Create_Statement (SQL);
      begin
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement and initialize the SQL statement with the query definition.
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.Queries.Query_Definition_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Index : constant ADO.Drivers.Driver_Index := Database.Impl.Database.Get_Driver_Index;
         SQL   : constant String := ADO.Queries.Get_SQL (Query, Index, False);
      begin
         return Database.Impl.Database.Create_Statement (SQL);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in ADO.SQL.Query'Class;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : Query_Statement := Database.Impl.Database.Create_Statement (Table);
      begin
         if Query in ADO.Queries.Context'Class then
            declare
               Pos : constant ADO.Drivers.Driver_Index := Database.Impl.Database.Get_Driver_Index;
               SQL : constant String := ADO.Queries.Context'Class (Query).Get_SQL (Pos);
            begin
               ADO.SQL.Append (Stmt.Get_Query.SQL, SQL);
            end;
         end if;
         Stmt.Set_Parameters (Query);
         return Stmt;
      end;
   end Create_Statement;

   --  ---------
   --  Master Session
   --  ---------

   --  ------------------------------
   --  Start a transaction.
   --  ------------------------------
   procedure Begin_Transaction (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Begin transaction {0}");
      Database.Impl.Database.Begin_Transaction;
   end Begin_Transaction;

   --  ------------------------------
   --  Commit the current transaction.
   --  ------------------------------
   procedure Commit (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Commit transaction {0}");
      Database.Impl.Database.Commit;
   end Commit;

   --  ------------------------------
   --  Rollback the current transaction.
   --  ------------------------------
   procedure Rollback (Database : in out Master_Session) is
   begin
      Check_Session (Database, "Rollback transaction {0}");
      Database.Impl.Database.Rollback;
   end Rollback;

   --  ------------------------------
   --  Allocate an identifier for the table.
   --  ------------------------------
   procedure Allocate (Database : in out Master_Session;
                       Id       : in out ADO.Objects.Object_Record'Class) is
   begin
      Check_Session (Database);
      ADO.Sequences.Allocate (Database.Sequences.all, Id);
   end Allocate;

   --  ------------------------------
   --  Flush the objects that were modified.
   --  ------------------------------
   procedure Flush (Database : in out Master_Session) is
   begin
      Check_Session (Database);
   end Flush;

   overriding
   procedure Adjust (Object : in out Session) is
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Increment (Object.Impl.Counter);
      end if;
   end Adjust;

   overriding
   procedure Finalize (Object : in out Session) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Session_Record,
                                         Name   => Session_Record_Access);
      Is_Zero : Boolean;
   begin
      if Object.Impl /= null then
         Util.Concurrent.Counters.Decrement (Object.Impl.Counter, Is_Zero);
         if Is_Zero then
            ADO.Objects.Release_Proxy (Object.Impl.Proxy);
            Object.Impl.Database.Close;
            Free (Object.Impl);
         end if;
         Object.Impl := null;
      end if;
   end Finalize;

   --  ------------------------------
   --  Create a delete statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement is
   begin
      Check_Session (Database);
      return Database.Impl.Database.Create_Statement (Table);
   end Create_Statement;

   --  ------------------------------
   --  Internal method to get the session proxy associated with the given database session.
   --  The session proxy is associated with some ADO objects to be able to retrieve the database
   --  session for the implementation of lazy loading.  The session proxy is kept until the
   --  session exist and at least one ADO object is refering to it.
   --  ------------------------------
   function Get_Session_Proxy (Database : in Session) return ADO.Objects.Session_Proxy_Access is
      use type ADO.Objects.Session_Proxy_Access;
   begin
      Check_Session (Database);
      if Database.Impl.Proxy = null then
         Database.Impl.Proxy := ADO.Objects.Create_Session_Proxy (Database.Impl);
      end if;
      return Database.Impl.Proxy;
   end Get_Session_Proxy;

end ADO.Sessions;

Update the Create_Statement operation to use the normal query definition


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

with Util.Tests;
with AWA.Tests;

package AWA.Users.Tests is

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

   type Test is new AWA.Tests.Test with null record;

   --  Test creation of user by simulating web requests.
   procedure Test_Create_User (T : in out Test);

   procedure Test_Logout_User (T : in out Test);

   --  Test user authentication by simulating a web request.
   procedure Test_Login_User (T : in out Test);

   --  Test the reset password by simulating web requests.
   procedure Test_Reset_Password_User (T : in out Test);

   --  Run the recovery password process for the given user and change the password.
   procedure Recover_Password (T        : in out Test;
                               Email    : in String;
                               Password : in String);

end AWA.Users.Tests;

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

with Util.Tests;
with AWA.Tests;

package AWA.Users.Tests is

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

   type Test is new AWA.Tests.Test with null record;

   --  Test creation of user by simulating web requests.
   procedure Test_Create_User (T : in out Test);

   procedure Test_Logout_User (T : in out Test);

   --  Test user authentication by simulating a web request.
   procedure Test_Login_User (T : in out Test);

   --  Test the reset password by simulating web requests.
   procedure Test_Reset_Password_User (T : in out Test);

   --  Test OAuth access using a fake OAuth provider.
   procedure Test_OAuth_Login (T : in out Test);

   --  Run the recovery password process for the given user and change the password.
   procedure Recover_Password (T        : in out Test;
                               Email    : in String;
                               Password : in String);

end AWA.Users.Tests;

Declare the Test_OAuth_Login procedure

Declare the Test_OAuth_Login procedure


-----------------------------------------------------------------------
--  wiki-strings -- Wiki string types and operations
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Wide_Wide_Unbounded;
with Ada.Characters.Conversions;
with Util.Texts.Builders;

package Wiki.Strings is

   pragma Preelaborate;

   subtype WChar is Wide_Wide_Character;
   subtype WString is Wide_Wide_String;
   subtype UString is Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;

   function To_WChar (C : in Character) return WChar
                      renames Ada.Characters.Conversions.To_Wide_Wide_Character;

   function To_Char (C : in WChar; Substitute : in Character := ' ') return Character
                     renames Ada.Characters.Conversions.To_Character;

   function To_UString (S : in WString) return UString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String;

   function To_WString (S : in UString) return WString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String;

   Null_UString : UString
   renames Ada.Strings.Wide_Wide_Unbounded.Null_Unbounded_Wide_Wide_String;

   package Wide_Wide_Builders is new Util.Texts.Builders (Element_Type => WChar,
                                                          Input        => WString,
                                                          Chunk_Size   => 512);

   subtype BString is Wide_Wide_Builders.Builder;

end Wiki.Strings;

-----------------------------------------------------------------------
--  wiki-strings -- Wiki string types and operations
--  Copyright (C) 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Wide_Wide_Unbounded;
with Ada.Characters.Conversions;
with Util.Texts.Builders;

package Wiki.Strings is

   pragma Preelaborate;

   subtype WChar is Wide_Wide_Character;
   subtype WString is Wide_Wide_String;
   subtype UString is Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String;

   function To_WChar (C : in Character) return WChar
                      renames Ada.Characters.Conversions.To_Wide_Wide_Character;

   function To_Char (C : in WChar; Substitute : in Character := ' ') return Character
                     renames Ada.Characters.Conversions.To_Character;

   function To_String (S : in WString; Substitute : in Character := ' ') return String
                       renames Ada.Characters.Conversions.To_String;

   function To_UString (S : in WString) return UString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Unbounded_Wide_Wide_String;

   function To_WString (S : in UString) return WString
                        renames Ada.Strings.Wide_Wide_Unbounded.To_Wide_Wide_String;

   Null_UString : UString
   renames Ada.Strings.Wide_Wide_Unbounded.Null_Unbounded_Wide_Wide_String;

   package Wide_Wide_Builders is new Util.Texts.Builders (Element_Type => WChar,
                                                          Input        => WString,
                                                          Chunk_Size   => 512);

   subtype BString is Wide_Wide_Builders.Builder;

end Wiki.Strings;

Declare the To_String function

Declare the To_String function


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

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

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 not Queue.Queue.Has_Queue 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;

Use the Has_Queue operation in Senq_Queue procedure


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

with Ada.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;

package body Security.Policies.Urls is

   --  ------------------------------
   --  URL policy
   --  ------------------------------

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

   --  Returns True if the user has the permission to access the given URI permission.
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URI_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URI);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URI);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------
   type Policy_Config is record
      Id          : Natural := 0;
      Permissions : Util.Beans.Objects.Vectors.Vector;
      Patterns    : Util.Beans.Objects.Vectors.Vector;
      Manager     : URL_Policy_Access;
   end record;
   type Policy_Config_Access is access all Policy_Config;

   --  Setup the XML parser to read the policy description.  For example:

   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out URL_Policy) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in out URL_Policy'Class) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

begin
   Policy_Mapping.Add_Mapping ("url-policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("url-policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("url-policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("url-policy/url-pattern", FIELD_URL_PATTERN);
end Security.Policies.Urls;

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

with Ada.Unchecked_Deallocation;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Contexts;

package body Security.Policies.URLs is

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

   --  ------------------------------
   --  Returns True if the user has the permission to access the given URI permission.
   --  ------------------------------
   function Has_Permission (Manager    : in URL_Policy;
                            Context    : in Security_Context_Access;
                            Permission : in URL_Permission'Class) return Boolean is
      Name  : constant String_Ref := To_String_Ref (Permission.URL);
      Ref   : constant Rules_Ref.Ref := Manager.Cache.Get;
      Rules : constant Rules_Access := Ref.Value;
      Pos   : constant Rules_Maps.Cursor := Rules.Map.Find (Name);
      Rule  : Access_Rule_Ref;
   begin
      --  If the rule is not in the cache, search for the access rule that
      --  matches our URI.  Update the cache.  This cache update is thread-safe
      --  as the cache map is never modified: a new cache map is installed.
      if not Rules_Maps.Has_Element (Pos) then
         declare
            New_Ref : constant Rules_Ref.Ref := Rules_Ref.Create;
         begin
            Rule := Manager.Find_Access_Rule (Permission.URL);
            New_Ref.Value.all.Map := Rules.Map;
            New_Ref.Value.all.Map.Insert (Name, Rule);
            Manager.Cache.Set (New_Ref);
         end;
      else
         Rule := Rules_Maps.Element (Pos);
      end if;

      --  Check if the user has one of the required permission.
      declare
         P       : constant Access_Rule_Access := Rule.Value;
         Granted : Boolean;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               Context.Has_Permission (P.Permissions (I), Granted);
               if Granted then
                  return True;
               end if;
            end loop;
         end if;
      end;
      return False;
   end Has_Permission;

   --  Grant the permission to access to the given URI to users having the To
   --  permissions.
   procedure Grant_URI_Permission (Manager : in out URL_Policy;
                                   URI     : in String;
                                   To      : in String) is
   begin
      null;
   end Grant_URI_Permission;

   --  ------------------------------
   --  Policy Configuration
   --  ------------------------------

   --  ------------------------------
   --  Find the access rule of the policy that matches the given URI.
   --  Returns the No_Rule value (disable access) if no rule is found.
   --  ------------------------------
   function Find_Access_Rule (Manager : in URL_Policy;
                              URI     : in String) return Access_Rule_Ref is

      Matched : Boolean := False;
      Result  : Access_Rule_Ref;

      procedure Match (P : in Policy);

      procedure Match (P : in Policy) is
      begin
         if GNAT.Regexp.Match (URI, P.Pattern) then
            Matched := True;
            Result  := P.Rule;
         end if;
      end Match;

      Last : constant Natural := Manager.Policies.Last_Index;
   begin
      for I in 1 .. Last loop
         Manager.Policies.Query_Element (I, Match'Access);
         if Matched then
            return Result;
         end if;
      end loop;
      return Result;
   end Find_Access_Rule;

   --  ------------------------------
   --  Initialize the permission manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out URL_Policy) is
   begin
      Manager.Cache := new Rules_Ref.Atomic_Ref;
      Manager.Cache.Set (Rules_Ref.Create);
   end Initialize;

   --  ------------------------------
   --  Finalize the permission manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out URL_Policy) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
   begin
      Free (Manager.Cache);
--        for I in Manager.Names'Range loop
--           exit when Manager.Names (I) = null;
--           Ada.Strings.Unbounded.Free (Manager.Names (I));
--        end loop;

   end Finalize;

   type Policy_Fields is (FIELD_ID, FIELD_PERMISSION, FIELD_URL_PATTERN, FIELD_POLICY);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Process (Policy : in out URL_Policy'Class);

   procedure Set_Member (P     : in out URL_Policy'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_ID =>
            P.Id := Util.Beans.Objects.To_Integer (Value);

         when FIELD_PERMISSION =>
            P.Permissions.Append (Value);

         when FIELD_URL_PATTERN =>
            P.Patterns.Append (Value);

         when FIELD_POLICY =>
            Process (P);
            P.Id := 0;
            P.Permissions.Clear;
            P.Patterns.Clear;

      end case;
   end Set_Member;

   procedure Process (Policy : in out URL_Policy'Class) is
      Pol    : Security.Policies.URLs.Policy;
      Count  : constant Natural := Natural (Policy.Permissions.Length);
      Rule   : constant Access_Rule_Ref := Access_Rule_Refs.Create (new Access_Rule (Count));
      Iter   : Util.Beans.Objects.Vectors.Cursor := Policy.Permissions.First;
      Pos    : Positive := 1;
   begin
      Pol.Rule := Rule;

      --  Step 1: Initialize the list of permission index in Access_Rule from the permission names.
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Perm : constant Util.Beans.Objects.Object := Util.Beans.Objects.Vectors.Element (Iter);
            Name : constant String := Util.Beans.Objects.To_String (Perm);
         begin
            Rule.Value.all.Permissions (Pos) := Permissions.Get_Permission_Index (Name);
            Pos := Pos + 1;

         exception
            when Invalid_Name =>
               raise Util.Serialize.Mappers.Field_Error with "Invalid permission: " & Name;
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;

      --  Step 2: Create one policy for each URL pattern
      Iter := Policy.Patterns.First;
      while Util.Beans.Objects.Vectors.Has_Element (Iter) loop
         declare
            Pattern : constant Util.Beans.Objects.Object
              := Util.Beans.Objects.Vectors.Element (Iter);
         begin
            Pol.Id   := Policy.Id;
            Pol.Pattern := GNAT.Regexp.Compile (Util.Beans.Objects.To_String (Pattern));
            Policy.Policies.Append (Pol);
         end;
         Util.Beans.Objects.Vectors.Next (Iter);
      end loop;
   end Process;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => URL_Policy'Class,
                                               Element_Type_Access => URL_Policy_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out URL_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
   begin
      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Reader.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Policy'Unchecked_Access);
   end Prepare_Config;

   --  ------------------------------
   --  Get the URL policy associated with the given policy manager.
   --  Returns the URL policy instance or null if it was not registered in the policy manager.
   --  ------------------------------
   function Get_URL_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                            return URL_Policy_Access is
      Policy : constant Security.Policies.Policy_Access := Manager.Get_Policy (NAME);
   begin
      if Policy = null or else not (Policy.all in URL_Policy'Class) then
         return null;
      else
         return URL_Policy'Class (Policy.all)'Access;
      end if;
   end Get_URL_Policy;

begin
   Policy_Mapping.Add_Mapping ("url-policy", FIELD_POLICY);
   Policy_Mapping.Add_Mapping ("url-policy/@id", FIELD_ID);
   Policy_Mapping.Add_Mapping ("url-policy/permission", FIELD_PERMISSION);
   Policy_Mapping.Add_Mapping ("url-policy/url-pattern", FIELD_URL_PATTERN);
end Security.Policies.URLs;

Rename the package URLs

Rename the package URLs