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

with Util.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

   --  Parse the stream using the CSV parser.
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class);

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
   end record;

end Util.Serialize.IO.CSV;

-----------------------------------------------------------------------
--  util-serialize-io-csv -- CSV Serialization Driver
--  Copyright (C) 2011, 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.Strings.Vectors;
with Util.Streams.Texts;

--  The Util.Serialize.IO.CSV package allows to read and write CSV files.
--
--  See RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
package Util.Serialize.IO.CSV is

   type Row_Type is new Natural;
   type Column_Type is new Positive;

   --  ------------------------------
   --  CSV Output Stream
   --  ------------------------------
   --  The Output_Stream provides methods for creating a CSV output stream.
   --  The stream object takes care of the CSV escape rules.
   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with private;

   --  Write the value as a CSV cell.  Special characters are escaped using the CSV
   --  escape rules.
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in String);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Integer);
  procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Boolean);
   procedure Write_Cell (Stream : in out Output_Stream;
                         Value  : in Util.Beans.Objects.Object);

   --  Start a new row.
   procedure New_Row (Stream : in out Output_Stream);

   --  Write the attribute name/value pair.
   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String);

   overriding
   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean);

   overriding
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object);

   --  Write the entity value.
   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String);

   overriding
   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer);

   overriding
   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer);

   overriding
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  CSV Parser
   --  ------------------------------
   --  The Parser type is a CSV parser which allows to map CVS rows directly
   --  in Ada records.
   type Parser is new Serialize.IO.Parser with private;

   --  Get the header name for the given column.
   --  If there was no header line, build a default header for the column.
   function Get_Header_Name (Handler : in Parser;
                             Column  : in Column_Type) return String;

   --  Set the cell value at the given row and column.
   --  The default implementation finds the column header name and
   --  invokes Write_Entity with the header name and the value.
   procedure Set_Cell (Handler : in out Parser;
                       Value   : in String;
                       Row     : in Row_Type;
                       Column  : in Column_Type);

   --  Set the field separator.  The default field separator is the comma (',').
   procedure Set_Field_Separator (Handler   : in out Parser;
                                  Separator : in Character);

   --  Get the field separator.
   function Get_Field_Separator (Handler : in Parser) return Character;

   --  Set the comment separator.  When a comment separator is defined, a line which starts
   --  with the comment separator will be ignored.  The row number will not be incremented.
   procedure Set_Comment_Separator (Handler   : in out Parser;
                                    Separator : in Character);

   --  Get the comment separator.  Returns ASCII.NUL if comments are not supported.
   function Get_Comment_Separator (Handler   : in Parser) return Character;

   --  Setup the CSV parser and mapper to use the default column header names.
   --  When activated, the first row is assumed to contain the first item to de-serialize.
   procedure Set_Default_Headers (Handler : in out Parser;
                                  Mode    : in Boolean := True);

   --  Parse the stream using the CSV parser.
   overriding
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class);

   --  Get the current location (file and line) to report an error message.
   overriding
   function Get_Location (Handler : in Parser) return String;

private

   type Output_Stream is
     new Util.Streams.Texts.Print_Stream and Util.Serialize.IO.Output_Stream with record
      Max_Columns : Column_Type := 1;
      Column      : Column_Type := 1;
      Row         : Row_Type := 0;
   end record;

   type Parser is new Util.Serialize.IO.Parser with record
      Has_Header  : Boolean := True;
      Line_Number : Natural  := 1;
      Row         : Row_Type := 0;
      Headers     : Util.Strings.Vectors.Vector;
      Separator   : Character := ',';
      Comment     : Character := ASCII.NUL;
      Use_Default_Headers : Boolean := False;
   end record;

end Util.Serialize.IO.CSV;

Declare the Write_Cell, Write_Wide_Entity, Write_Wide_Attribute procedures for CSV stream generation


-----------------------------------------------------------------------
--  security-policies-urls -- URL security policy
--  Copyright (C) 2010, 2011, 2012, 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.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers.URLs;

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 Contexts.Security_Context'Class;
                            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;
      begin
         if P /= null then
            for I in P.Permissions'Range loop
               if Context.Has_Permission (P.Permissions (I)) 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);
   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;
                             Mapper : in out Util.Serialize.Mappers.Processing) is
      Perm : Security.Controllers.URLs.URL_Controller_Access;
   begin
      Mapper.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Mapper.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Mapper, Policy'Unchecked_Access);
      if not Policy.Manager.Has_Controller (P_URL.Permission) then
         Perm := new Security.Controllers.URLs.URL_Controller;
         Perm.Manager := Policy'Unchecked_Access;
         Policy.Manager.Add_Permission (Name       => "url",
                                        Permission => Perm.all'Access);
      end if;
   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, 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.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers.URLs;

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 Contexts.Security_Context'Class;
                            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_Ref.Element_Accessor := 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.Map := Rules.Map;
            New_Ref.Value.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.
      if not Rule.Is_Null then
         declare
            P : constant Access_Rule_Refs.Element_Accessor := Rule.Value;
         begin
            for I in P.Permissions'Range loop
               if Context.Has_Permission (P.Permissions (I)) then
                  return True;
               end if;
            end loop;
         end;
      end if;
      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 Atomic_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 (Atomic_Rules_Ref.Atomic_Ref,
                                        Rules_Ref_Access);
   begin
      Free (Manager.Cache);
   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.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;
                             Mapper : in out Util.Serialize.Mappers.Processing) is
      Perm : Security.Controllers.URLs.URL_Controller_Access;
   begin
      Mapper.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Mapper.Add_Mapping ("module", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Mapper, Policy'Unchecked_Access);
      if not Policy.Manager.Has_Controller (P_URL.Permission) then
         Perm := new Security.Controllers.URLs.URL_Controller;
         Perm.Manager := Policy'Unchecked_Access;
         Policy.Manager.Add_Permission (Name       => "url",
                                        Permission => Perm.all'Access);
      end if;
   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;

Update after changes in Util.Refs package


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

with Ada.Unchecked_Deallocation;

package body Util.Concurrent.Arrays is

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Vector_Record,
                                      Name   => Vector_Record_Access);

   --  ------------------------------
   --  Returns True if the container is empty.
   --  ------------------------------
   function Is_Empty (Container : in Ref) return Boolean is
   begin
      return Container.Target = null;
   end Is_Empty;

   --  ------------------------------
   --  Iterate over the vector elements and execute the Process procedure
   --  with the element as parameter.
   --  ------------------------------
   procedure Iterate (Container : in Ref;
                      Process   : not null access procedure (Item : in Element_Type)) is
      Target : constant Vector_Record_Access := Container.Target;
   begin
      if Target /= null then
         for I in Target.List'Range loop
            Process (Target.List (I));
         end loop;
      end if;
   end Iterate;

   --  ------------------------------
   --  Iterate over the vector elements in reverse order and execute the Process procedure
   --  with the element as parameter.
   --  ------------------------------
   procedure Reverse_Iterate (Container : in Ref;
                              Process   : not null access procedure (Item : in Element_Type)) is
      Target : constant Vector_Record_Access := Container.Target;
   begin
      if Target /= null then
         for I in reverse Target.List'Range loop
            Process (Target.List (I));
         end loop;
      end if;
   end Reverse_Iterate;

   --  ------------------------------
   --  Release the reference.  Invoke Finalize and free the storage if it was
   --  the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Ref) is
      Release : Boolean;
   begin
      if Obj.Target /= null then
         Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
         if Release then
            Free (Obj.Target);
         else
            Obj.Target := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference counter after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Ref) is
   begin
      if Obj.Target /= null then
         Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
      end if;
   end Adjust;

   --  ------------------------------
   --  Get a read-only reference to the vector elements.  The referenced vector will never
   --  be modified.
   --  ------------------------------
   function Get (Container : in Vector'Class) return Ref is
   begin
      return Container.List.Get;
   end Get;

   --  ------------------------------
   --  Append the element to the vector.  The modification will not be visible to readers
   --  until they call the Get function.
   --  ------------------------------
   procedure Append (Container : in out Vector;
                     Item      : in Element_Type) is
   begin
      Container.List.Append (Item);
   end Append;

   --  ------------------------------
   --  Remove the element represented by Item from the vector.  The modification will
   --  not be visible to readers until they call the Get function.
   --  ------------------------------
   procedure Remove (Container : in out Vector;
                     Item      : in Element_Type) is
   begin
      Container.List.Remove (Item);
   end Remove;

   --  Release the vector elements.
   overriding
   procedure Finalize (Object : in out Vector) is
   begin
      null;
   end Finalize;

   --  Vector of objects
   protected body Protected_Vector is

      --  ------------------------------
      --  Get a readonly reference to the vector.
      --  ------------------------------
      function Get return Ref is
      begin
         return Elements;
      end Get;

      --  ------------------------------
      --  Append the element to the vector.
      --  ------------------------------
      procedure Append (Item : in Element_Type) is
         New_Items : Vector_Record_Access;
         Len       : Natural;
      begin
         if Elements.Target = null then
            New_Items := new Vector_Record (Len => 1);

            Len := 1;
         else
            Len := Elements.Target.Len + 1;
            New_Items := new Vector_Record (Len => Len);
            New_Items.List (1 .. Len - 1) := Elements.Target.List;
            Finalize (Elements);
         end if;

         New_Items.List (Len) := Item;
         Util.Concurrent.Counters.Increment (New_Items.Ref_Counter);
         Elements.Target := New_Items;
      end Append;

      --  ------------------------------
      --  Remove the element from the vector.
      --  ------------------------------
      procedure Remove (Item : in Element_Type) is
         New_Items : Vector_Record_Access;
         Items     : constant Vector_Record_Access := Elements.Target;
      begin
         if Items = null then
            return;
         end if;
         for I in Items.List'Range loop
            if Items.List (I) = Item then
               if Items.Len = 0 then
                  Finalize (Elements);
                  Elements.Target := null;
               else
                  New_Items := new Vector_Record (Len => Items.Len - 1);
                  if I > 1 then
                     New_Items.List (1 .. I - 1) := Items.List (1 .. I - 1);
                  end if;
                  if I <= New_Items.List'Last then
                     New_Items.List (I .. New_Items.List'Last)
                       := Items.List (I + 1 .. Items.List'Last);
                  end if;
                  Finalize (Elements);
                  Util.Concurrent.Counters.Increment (New_Items.Ref_Counter);
                  Elements.Target := New_Items;
               end if;
               return;
            end if;
         end loop;
      end Remove;

   end Protected_Vector;

end Util.Concurrent.Arrays;

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

with Ada.Unchecked_Deallocation;

package body Util.Concurrent.Arrays is

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Vector_Record,
                                      Name   => Vector_Record_Access);

   --  ------------------------------
   --  Returns True if the container is empty.
   --  ------------------------------
   function Is_Empty (Container : in Ref) return Boolean is
   begin
      return Container.Target = null;
   end Is_Empty;

   --  ------------------------------
   --  Iterate over the vector elements and execute the Process procedure
   --  with the element as parameter.
   --  ------------------------------
   procedure Iterate (Container : in Ref;
                      Process   : not null access procedure (Item : in Element_Type)) is
      Target : constant Vector_Record_Access := Container.Target;
   begin
      if Target /= null then
         for I in Target.List'Range loop
            Process (Target.List (I));
         end loop;
      end if;
   end Iterate;

   --  ------------------------------
   --  Iterate over the vector elements in reverse order and execute the Process procedure
   --  with the element as parameter.
   --  ------------------------------
   procedure Reverse_Iterate (Container : in Ref;
                              Process   : not null access procedure (Item : in Element_Type)) is
      Target : constant Vector_Record_Access := Container.Target;
   begin
      if Target /= null then
         for I in reverse Target.List'Range loop
            Process (Target.List (I));
         end loop;
      end if;
   end Reverse_Iterate;

   --  ------------------------------
   --  Release the reference.  Invoke Finalize and free the storage if it was
   --  the last reference.
   --  ------------------------------
   overriding
   procedure Finalize (Obj : in out Ref) is
      Release : Boolean;
   begin
      if Obj.Target /= null then
         Util.Concurrent.Counters.Decrement (Obj.Target.Ref_Counter, Release);
         if Release then
            Free (Obj.Target);
         else
            Obj.Target := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Update the reference counter after an assignment.
   --  ------------------------------
   overriding
   procedure Adjust (Obj : in out Ref) is
   begin
      if Obj.Target /= null then
         Util.Concurrent.Counters.Increment (Obj.Target.Ref_Counter);
      end if;
   end Adjust;

   --  ------------------------------
   --  Get a read-only reference to the vector elements.  The referenced vector will never
   --  be modified.
   --  ------------------------------
   function Get (Container : in Vector'Class) return Ref is
   begin
      return Container.List.Get;
   end Get;

   --  ------------------------------
   --  Append the element to the vector.  The modification will not be visible to readers
   --  until they call the Get function.
   --  ------------------------------
   procedure Append (Container : in out Vector;
                     Item      : in Element_Type) is
   begin
      Container.List.Append (Item);
   end Append;

   --  ------------------------------
   --  Remove the element represented by Item from the vector.  The modification will
   --  not be visible to readers until they call the Get function.
   --  ------------------------------
   procedure Remove (Container : in out Vector;
                     Item      : in Element_Type) is
   begin
      Container.List.Remove (Item);
   end Remove;

   --  Release the vector elements.
   overriding
   procedure Finalize (Object : in out Vector) is
   begin
      null;
   end Finalize;

   --  Vector of objects
   protected body Protected_Vector is

      --  ------------------------------
      --  Get a readonly reference to the vector.
      --  ------------------------------
      function Get return Ref is
      begin
         return Elements;
      end Get;

      --  ------------------------------
      --  Append the element to the vector.
      --  ------------------------------
      procedure Append (Item : in Element_Type) is
         New_Items : Vector_Record_Access;
         Len       : Natural;
      begin
         if Elements.Target = null then
            New_Items := new Vector_Record (Len => 1);

            Len := 1;
         else
            Len := Elements.Target.Len + 1;
            New_Items := new Vector_Record (Len => Len);
            New_Items.List (1 .. Len - 1) := Elements.Target.List;
            Finalize (Elements);
         end if;

         New_Items.List (Len) := Item;
         Util.Concurrent.Counters.Increment (New_Items.Ref_Counter);
         Elements.Target := New_Items;
      end Append;

      --  ------------------------------
      --  Remove the element from the vector.
      --  ------------------------------
      procedure Remove (Item : in Element_Type) is
         New_Items : Vector_Record_Access;
         Items     : constant Vector_Record_Access := Elements.Target;
      begin
         if Items = null then
            return;
         end if;
         for I in Items.List'Range loop
            if Items.List (I) = Item then
               if Items.Len = 1 then
                  Finalize (Elements);
                  Elements.Target := null;
               else
                  New_Items := new Vector_Record (Len => Items.Len - 1);
                  if I > 1 then
                     New_Items.List (1 .. I - 1) := Items.List (1 .. I - 1);
                  end if;
                  if I <= New_Items.List'Last then
                     New_Items.List (I .. New_Items.List'Last)
                       := Items.List (I + 1 .. Items.List'Last);
                  end if;
                  Finalize (Elements);
                  Util.Concurrent.Counters.Increment (New_Items.Ref_Counter);
                  Elements.Target := New_Items;
               end if;
               return;
            end if;
         end loop;
      end Remove;

   end Protected_Vector;

end Util.Concurrent.Arrays;

Fix removal of last element

Fix removal of last element


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

with Util.Test_Caller;
with Util.Log.Loggers;
with Util.Measures;
with ASF.Requests.Mockup;
package body ASF.Requests.Tests is

   use Util.Tests;
   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("ASF.Requests.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Requests.Split_Header",
                       Test_Split_Header'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Accept_Locales",
                       Test_Accept_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Split_Header procedure.
   --  ------------------------------
   procedure Test_Split_Header (T : in out Test) is
      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type);

      Count : Natural := 0;

      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type) is
      begin
         T.Assert (Item = "text/plain" or Item = "text/html" or Item = "text/x-dvi"
                   or Item = "text/x-c", "Invalid item: " & Item);
         T.Assert (Quality = 0.5 or Quality = 0.8 or Quality = 1.0,
                   "Invalid quality");
         if Item = "text/plain" then
            T.Assert (Quality = 0.5, "Invalid quality for " & Item);

         elsif Item = "text/x-dvi" or Item = "text/html" then
            T.Assert (Quality = 0.8, "Invalid quality for " & Item);

         else
            T.Assert (Quality = 1.0, "Invalid quality for " & Item);
         end if;
         Count := Count + 1;
      end Process_Text;

   begin
      Split_Header ("text/plain; q=0.5, text/html,text/x-dvi; q=0.8, text/x-c",
                    Process_Text'Access);
      Util.Tests.Assert_Equals (T, 4, Count, "Invalid number of items");
   end Test_Split_Header;

   --  ------------------------------
   --  Test the Accept_Locales procedure.
   --  ------------------------------
   procedure Test_Accept_Locales (T : in out Test) is
      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type);

      use Util.Locales;

      Req : ASF.Requests.Mockup.Request;

      Count : Natural := 0;

      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type) is
         Lang : constant String := Util.Locales.Get_Language (Locale);
      begin
         Log.Info ("Found locale: {0}", Util.Locales.To_String (Locale));

         T.Assert (Lang = "da" or Lang = "en_GB" or Lang = "en",
                   "Invalid lang: " & Lang);

         Count := Count + 1;
      end Process_Locale;

   begin
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.8, en;q=0.7");
      Req.Accept_Locales (Process_Locale'Access);

      Util.Tests.Assert_Equals (T, 3, Count, "Invalid number of calls");
   end Test_Accept_Locales;

end ASF.Requests.Tests;

-----------------------------------------------------------------------
--  asf-requests-tests - Unit tests for requests
--  Copyright (C) 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.Test_Caller;
with Util.Log.Loggers;
with ASF.Requests.Mockup;
package body ASF.Requests.Tests is

   use Util.Tests;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Requests.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Requests.Split_Header",
                       Test_Split_Header'Access);
      Caller.Add_Test (Suite, "Test ASF.Requests.Accept_Locales",
                       Test_Accept_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test the Split_Header procedure.
   --  ------------------------------
   procedure Test_Split_Header (T : in out Test) is
      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type);

      Count : Natural := 0;

      procedure Process_Text (Item    : in String;
                              Quality : in Quality_Type) is
      begin
         T.Assert (Item = "text/plain" or Item = "text/html" or Item = "text/x-dvi"
                   or Item = "text/x-c", "Invalid item: " & Item);
         T.Assert (Quality = 0.5 or Quality = 0.8 or Quality = 1.0,
                   "Invalid quality");
         if Item = "text/plain" then
            T.Assert (Quality = 0.5, "Invalid quality for " & Item);

         elsif Item = "text/x-dvi" or Item = "text/html" then
            T.Assert (Quality = 0.8, "Invalid quality for " & Item);

         else
            T.Assert (Quality = 1.0, "Invalid quality for " & Item);
         end if;
         Count := Count + 1;
      end Process_Text;

   begin
      Split_Header ("text/plain; q=0.5, text/html,text/x-dvi; q=0.8, text/x-c",
                    Process_Text'Access);
      Util.Tests.Assert_Equals (T, 4, Count, "Invalid number of items");
   end Test_Split_Header;

   --  ------------------------------
   --  Test the Accept_Locales procedure.
   --  ------------------------------
   procedure Test_Accept_Locales (T : in out Test) is
      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type);

      use Util.Locales;

      Req : ASF.Requests.Mockup.Request;

      Count : Natural := 0;

      procedure Process_Locale (Locale : in Util.Locales.Locale;
                                Quality : in Quality_Type) is
         pragma Unreferenced (Quality);

         Lang : constant String := Util.Locales.Get_Language (Locale);
      begin
         Log.Info ("Found locale: {0}", Util.Locales.To_String (Locale));

         T.Assert (Lang = "da" or Lang = "en_GB" or Lang = "en",
                   "Invalid lang: " & Lang);

         Count := Count + 1;
      end Process_Locale;

   begin
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.8, en;q=0.7");
      Req.Accept_Locales (Process_Locale'Access);

      Util.Tests.Assert_Equals (T, 3, Count, "Invalid number of calls");
   end Test_Accept_Locales;

end ASF.Requests.Tests;

Fix compilation warning

Fix compilation warning


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

package body MAT.Events.Targets is

   ITERATE_COUNT : constant Event_Id_Type := 10_000;

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Probe_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type) is
   begin
      Target.Events.Insert (Event);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector) is
   begin
      Target.Events.Get_Events (Start, Finish, Into);
   end Get_Events;

   --  ------------------------------
   --  Get the start and finish time for the events that have been received.
   --  ------------------------------
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time) is
   begin
      Target.Events.Get_Time_Range (Start, Finish);
   end Get_Time_Range;

   --  ------------------------------
   --  Get the first and last event that have been received.
   --  ------------------------------
   procedure Get_Limits (Target : in out Target_Events;
                         First  : out Probe_Event_Type;
                         Last   : out Probe_Event_Type) is
   begin
      Target.Events.Get_Limits (First, Last);
   end Get_Limits;

   --  ------------------------------
   --  Get the probe event with the given allocated unique id.
   --  ------------------------------
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type is
   begin
      return Target.Events.Get_Event (Id);
   end Get_Event;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_Event_Counter;

   --  ------------------------------
   --  Iterate over the events starting from the <tt>Start</tt> event and until the
   --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
   --  with each event instance.
   --  ------------------------------
   procedure Iterate (Target  : in out Target_Events;
                      Start   : in Event_Id_Type;
                      Finish  : in Event_Id_Type;
                      Process : access procedure (Event : in Probe_Event_Type)) is
   begin
      Target.Events.Iterate (Start, Finish, Process);
   end Iterate;

   --  ------------------------------
   --  Iterate over the events starting from first first event up to the last event collected.
   --  Execute the <tt>Process</tt> procedure with each event instance.
   --  ------------------------------
   procedure Iterate (Target  : in out Target_Events;
                      Process : access procedure (Event : in Target_Event)) is
      First_Event : Target_Event;
      Last_Event  : Target_Event;
      First_Id    : Event_Id_Type;
   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         --  Iterate over the events in groups of 10_000 to release the lock and give some
         --  opportunity to the server thread to add new events.
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Process);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Iterate;

   --  ------------------------------
   --  Release the storage allocated for the events.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Events) is
   begin
      null;
   end Finalize;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event : in Probe_Event_Type) is
         Info : Target_Event;
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
            Ids.Insert (Last_Id + 1, Current);
         end if;
         Current.Count := Current.Count + 1;
         Current.Events (Current.Count) := Event;
         Current.Events (Current.Count).Id := Last_Id;
         Last_Id := Last_Id + 1;
         Current.Finish := Event.Time;
         if Current.Count = Current.Events'Last then
            Current := null;
         end if;
      end Insert;

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector) is
         Iter  : Event_Cursor := Events.Floor (Start);
         Block : Event_Block_Access;
      begin
         while Event_Maps.Has_Element (Iter) loop
            Block := Event_Maps.Element (Iter);
            exit when Block.Start > Finish;
            for I in Block.Events'First .. Block.Count loop
               exit when Block.Events (I).Time > Finish;
               if Block.Events (I).Time >= Start then
                  Into.Append (Block.Events (I));
               end if;
            end loop;
            Event_Maps.Next (Iter);
         end loop;
      end Get_Events;

      --  ------------------------------
      --  Get the start and finish time for the events that have been received.
      --  ------------------------------
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time) is
         First : constant Event_Block_Access := Events.First_Element;
         Last  : constant Event_Block_Access := Events.Last_Element;
      begin
         Start  := First.Events (First.Events'First).Time;
         Finish := Last.Events (Last.Count).Time;
      end Get_Time_Range;

      --  ------------------------------
      --  Get the first and last event that have been received.
      --  ------------------------------
      procedure Get_Limits (First : out Probe_Event_Type;
                            Last  : out Probe_Event_Type) is
         First_Block : constant Event_Block_Access := Events.First_Element;
         Last_Block  : constant Event_Block_Access := Events.Last_Element;
      begin
         First := First_Block.Events (First_Block.Events'First);
         Last  := Last_Block.Events (Last_Block.Count);
      end Get_Limits;

      --  ------------------------------
      --  Get the probe event with the given allocated unique id.
      --  ------------------------------
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type is
         Iter  : Event_Id_Cursor := Ids.Floor (Id);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
      begin
         while Event_Id_Maps.Has_Element (Iter) loop
            Block := Event_Id_Maps.Element (Iter);
            exit when Id < Block.Events (Block.Events'First).Id;
            Pos := Id - Block.Events (Block.Events'First).Id + Block.Events'First;
            if Pos <= Block.Count then
               return Block.Events (Pos);
            end if;
            Event_Id_Maps.Next (Iter);
         end loop;
         raise Not_Found;
      end Get_Event;

      --  ------------------------------
      --  Iterate over the events starting from the <tt>Start</tt> event and until the
      --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
      --  with each event instance.
      --  ------------------------------
      procedure Iterate (Start   : in Event_Id_Type;
                         Finish  : in Event_Id_Type;
                         Process : access procedure (Event : in Probe_Event_Type)) is
         Iter  : Event_Id_Cursor := Ids.Floor (Start);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
         Id    : Event_Id_Type := Start;
      begin
         --  First, find the block and position of the first event.
         while Event_Id_Maps.Has_Element (Iter) loop
            Block := Event_Id_Maps.Element (Iter);
            exit when Id < Block.Events (Block.Events'First).Id;
            Pos := Id - Block.Events (Block.Events'First).Id + Block.Events'First;
            if Start <= Finish then
               if Pos <= Block.Count then

                  --  Second, iterate over the events moving to the next event block
                  --  until we reach the last event.
                  loop
                     Process (Block.Events (Pos));
                     exit when Id > Finish;
                     Pos := Pos + 1;
                     Id := Id + 1;
                     if Pos > Block.Count then
                        Event_Id_Maps.Next (Iter);
                        exit when not Event_Id_Maps.Has_Element (Iter);
                        Block := Event_Id_Maps.Element (Iter);
                        Pos := Block.Events'First;
                     end if;
                  end loop;
               end if;
               Event_Id_Maps.Next (Iter);
            else
               if Pos <= Block.Count then

                  --  Second, iterate over the events moving to the next event block
                  --  until we reach the last event.
                  loop
                     Process (Block.Events (Pos));
                     exit when Id <= Finish;
                     Id := Id - 1;
                     if Pos = Block.Events'First then
                        Event_Id_Maps.Previous (Iter);
                        exit when not Event_Id_Maps.Has_Element (Iter);
                        Block := Event_Id_Maps.Element (Iter);
                        Pos := Block.Count;
                     else
                        Pos := Pos - 1;
                     end if;
                  end loop;
               end if;
               Event_Id_Maps.Previous (Iter);
            end if;
         end loop;
      end Iterate;

   end Event_Collector;

end MAT.Events.Targets;

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

   ITERATE_COUNT : constant Event_Id_Type := 10_000;

   --  ------------------------------
   --  Find in the list the first event with the given type.
   --  Raise <tt>Not_Found</tt> if the list does not contain such event.
   --  ------------------------------
   function Find (List : in Target_Event_Vector;
                  Kind : in Probe_Index_Type) return Probe_Event_Type is
      Iter  : Target_Event_Cursor := List.First;
      Event : Target_Event;
   begin
      while Target_Event_Vectors.Has_Element (Iter) loop
         Event := Target_Event_Vectors.Element (Iter);
         if Event.Index = Kind then
            return Event;
         end if;
         Target_Event_Vectors.Next (Iter);
      end loop;
      raise Not_Found;
   end Find;

   --  ------------------------------
   --  Extract from the frame info map, the list of event info sorted on the count.
   --  ------------------------------
   procedure Build_Event_Info (Map  : in Frame_Event_Info_Map;
                               List : in out Event_Info_Vector) is

      function "<" (Left, Right : in Event_Info_Type) return Boolean is
      begin
         return Left.Count < Right.Count;
      end "<";

      package Sort_Event_Info is new Event_Info_Vectors.Generic_Sorting;
      Iter : Frame_Event_Info_Cursor := Map.First;
      Item : Event_Info_Type;
   begin
      while Frame_Event_Info_Maps.Has_Element (Iter) loop
         Item := Frame_Event_Info_Maps.Element (Iter);
         List.Append (Item);
         Frame_Event_Info_Maps.Next (Iter);
      end loop;
      Sort_Event_Info.Sort (List);
   end Build_Event_Info;

   --  ------------------------------
   --  Add the event in the list of events and increment the event counter.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type) is
   begin
      Target.Events.Insert (Event);
      Util.Concurrent.Counters.Increment (Target.Event_Count);
   end Insert;

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector) is
   begin
      Target.Events.Get_Events (Start, Finish, Into);
   end Get_Events;

   --  ------------------------------
   --  Get the start and finish time for the events that have been received.
   --  ------------------------------
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time) is
   begin
      Target.Events.Get_Time_Range (Start, Finish);
   end Get_Time_Range;

   --  ------------------------------
   --  Get the first and last event that have been received.
   --  ------------------------------
   procedure Get_Limits (Target : in out Target_Events;
                         First  : out Probe_Event_Type;
                         Last   : out Probe_Event_Type) is
   begin
      Target.Events.Get_Limits (First, Last);
   end Get_Limits;

   --  ------------------------------
   --  Get the probe event with the given allocated unique id.
   --  ------------------------------
   function Get_Event (Target : in Target_Events;
                       Id     : in Event_Id_Type) return Probe_Event_Type is
   begin
      return Target.Events.Get_Event (Id);
   end Get_Event;

   --  ------------------------------
   --  Get the current event counter.
   --  ------------------------------
   function Get_Event_Counter (Target : in Target_Events) return Integer is
   begin
      return Util.Concurrent.Counters.Value (Target.Event_Count);
   end Get_Event_Counter;

   --  ------------------------------
   --  Iterate over the events starting from the <tt>Start</tt> event and until the
   --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
   --  with each event instance.
   --  ------------------------------
   procedure Iterate (Target  : in out Target_Events;
                      Start   : in Event_Id_Type;
                      Finish  : in Event_Id_Type;
                      Process : access procedure (Event : in Probe_Event_Type)) is
   begin
      Target.Events.Iterate (Start, Finish, Process);
   end Iterate;

   --  ------------------------------
   --  Iterate over the events starting from first first event up to the last event collected.
   --  Execute the <tt>Process</tt> procedure with each event instance.
   --  ------------------------------
   procedure Iterate (Target  : in out Target_Events;
                      Process : access procedure (Event : in Target_Event)) is
      First_Event : Target_Event;
      Last_Event  : Target_Event;
      First_Id    : Event_Id_Type;
   begin
      Target.Get_Limits (First_Event, Last_Event);
      First_Id := First_Event.Id;
      while First_Id < Last_Event.Id loop
         --  Iterate over the events in groups of 10_000 to release the lock and give some
         --  opportunity to the server thread to add new events.
         Target.Iterate (Start   => First_Id,
                         Finish  => First_Id + ITERATE_COUNT,
                         Process => Process);
         First_Id := First_Id + ITERATE_COUNT;
      end loop;
   end Iterate;

   --  ------------------------------
   --  Release the storage allocated for the events.
   --  ------------------------------
   overriding
   procedure Finalize (Target : in out Target_Events) is
   begin
      Target.Events.Clear;
   end Finalize;

   protected body Event_Collector is

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event : in Probe_Event_Type) is
         Info : Target_Event;
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
            Ids.Insert (Last_Id + 1, Current);
         end if;
         Current.Count := Current.Count + 1;
         Current.Events (Current.Count) := Event;
         Current.Events (Current.Count).Id := Last_Id;
         Last_Id := Last_Id + 1;
         Current.Finish := Event.Time;
         if Current.Count = Current.Events'Last then
            Current := null;
         end if;
      end Insert;

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector) is
         Iter  : Event_Cursor := Events.Floor (Start);
         Block : Event_Block_Access;
      begin
         while Event_Maps.Has_Element (Iter) loop
            Block := Event_Maps.Element (Iter);
            exit when Block.Start > Finish;
            for I in Block.Events'First .. Block.Count loop
               exit when Block.Events (I).Time > Finish;
               if Block.Events (I).Time >= Start then
                  Into.Append (Block.Events (I));
               end if;
            end loop;
            Event_Maps.Next (Iter);
         end loop;
      end Get_Events;

      --  ------------------------------
      --  Get the start and finish time for the events that have been received.
      --  ------------------------------
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time) is
         First : constant Event_Block_Access := Events.First_Element;
         Last  : constant Event_Block_Access := Events.Last_Element;
      begin
         Start  := First.Events (First.Events'First).Time;
         Finish := Last.Events (Last.Count).Time;
      end Get_Time_Range;

      --  ------------------------------
      --  Get the first and last event that have been received.
      --  ------------------------------
      procedure Get_Limits (First : out Probe_Event_Type;
                            Last  : out Probe_Event_Type) is
         First_Block : constant Event_Block_Access := Events.First_Element;
         Last_Block  : constant Event_Block_Access := Events.Last_Element;
      begin
         First := First_Block.Events (First_Block.Events'First);
         Last  := Last_Block.Events (Last_Block.Count);
      end Get_Limits;

      --  ------------------------------
      --  Get the probe event with the given allocated unique id.
      --  ------------------------------
      function Get_Event (Id : in Event_Id_Type) return Probe_Event_Type is
         Iter  : Event_Id_Cursor := Ids.Floor (Id);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
      begin
         while Event_Id_Maps.Has_Element (Iter) loop
            Block := Event_Id_Maps.Element (Iter);
            exit when Id < Block.Events (Block.Events'First).Id;
            Pos := Id - Block.Events (Block.Events'First).Id + Block.Events'First;
            if Pos <= Block.Count then
               return Block.Events (Pos);
            end if;
            Event_Id_Maps.Next (Iter);
         end loop;
         raise Not_Found;
      end Get_Event;

      --  ------------------------------
      --  Iterate over the events starting from the <tt>Start</tt> event and until the
      --  <tt>Finish</tt> event is found (inclusive).  Execute the <tt>Process</tt> procedure
      --  with each event instance.
      --  ------------------------------
      procedure Iterate (Start   : in Event_Id_Type;
                         Finish  : in Event_Id_Type;
                         Process : access procedure (Event : in Probe_Event_Type)) is
         Iter  : Event_Id_Cursor := Ids.Floor (Start);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
         Id    : Event_Id_Type := Start;
      begin
         --  First, find the block and position of the first event.
         while Event_Id_Maps.Has_Element (Iter) loop
            Block := Event_Id_Maps.Element (Iter);
            exit when Id < Block.Events (Block.Events'First).Id;
            Pos := Id - Block.Events (Block.Events'First).Id + Block.Events'First;
            if Start <= Finish then
               if Pos <= Block.Count then

                  --  Second, iterate over the events moving to the next event block
                  --  until we reach the last event.
                  loop
                     Process (Block.Events (Pos));
                     exit when Id > Finish;
                     Pos := Pos + 1;
                     Id := Id + 1;
                     if Pos > Block.Count then
                        Event_Id_Maps.Next (Iter);
                        exit when not Event_Id_Maps.Has_Element (Iter);
                        Block := Event_Id_Maps.Element (Iter);
                        Pos := Block.Events'First;
                     end if;
                  end loop;
               end if;
               Event_Id_Maps.Next (Iter);
            else
               if Pos <= Block.Count then

                  --  Second, iterate over the events moving to the next event block
                  --  until we reach the last event.
                  loop
                     Process (Block.Events (Pos));
                     exit when Id <= Finish;
                     Id := Id - 1;
                     if Pos = Block.Events'First then
                        Event_Id_Maps.Previous (Iter);
                        exit when not Event_Id_Maps.Has_Element (Iter);
                        Block := Event_Id_Maps.Element (Iter);
                        Pos := Block.Count;
                     else
                        Pos := Pos - 1;
                     end if;
                  end loop;
               end if;
               Event_Id_Maps.Previous (Iter);
            end if;
         end loop;
      end Iterate;

      --  ------------------------------
      --  Clear the events.
      --  ------------------------------
      procedure Clear is
         procedure Free is
            new Ada.Unchecked_Deallocation (Event_Block, Event_Block_Access);
      begin
         while not Events.Is_Empty loop
            declare
               Block : Event_Block_Access := Events.First_Element;
            begin
               Free (Block);
               Events.Delete_First;
            end;
         end loop;
         Current := null;
         Last_Id := 0;
         Ids.Clear;
      end Clear;

   end Event_Collector;

end MAT.Events.Targets;

Implement the protected procedure Clear to clear all the events and release the block event storage