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

with Ada.Exceptions;
with Ada.Real_Time;

with GL.Debug;
with GL.Low_Level.Enums;
with GL.Pixels;
with GL.Types;

with Orka.KTX;
with Orka.Resources.Locations;

package body Orka.Resources.Textures.KTX is

   package Debug_Messages is new GL.Debug.Messages (GL.Debug.Third_Party, GL.Debug.Other);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data     : Loaders.Resource_Data;
      Manager  : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr));

   -----------------------------------------------------------------------------

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr))
   is
      Bytes : Byte_Array_Access renames Object.Data.Bytes;
      Path  : String renames SU.To_String (Object.Data.Path);

      T1 : Ada.Real_Time.Time renames Object.Data.Start_Time;
      T2 : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Resource : constant Texture_Ptr := new Texture'(others => <>);
      begin
         T3 := Ada.Real_Time.Clock;

         --  Allocate storage
         case Header.Kind is
            when Texture_3D | Texture_2D_Array | Texture_Cube_Map_Array =>
               declare
                  Texture : GL.Objects.Textures.Texture_3D (Header.Kind);
               begin
                  if Header.Compressed then
                     Texture.Allocate_Storage (Levels, Header.Compressed_Format,
                       Header.Width, Header.Height, Header.Depth);
                  else
                     Texture.Allocate_Storage (Levels, Header.Internal_Format,
                       Header.Width, Header.Height, Header.Depth);
                  end if;
                  Resource.Texture.Replace_Element (Texture);
               end;
            when Texture_2D | Texture_1D_Array | Texture_Cube_Map =>
               declare
                  Texture : GL.Objects.Textures.Texture_2D (Header.Kind);
               begin
                  if Header.Compressed then
                     Texture.Allocate_Storage (Levels, Header.Compressed_Format,
                       Header.Width, Header.Height);
                  else
                     Texture.Allocate_Storage (Levels, Header.Internal_Format,
                       Header.Width, Header.Height);
                  end if;
                  Resource.Texture.Replace_Element (Texture);
               end;
            when Texture_1D =>
               declare
                  Texture : GL.Objects.Textures.Texture_1D (Header.Kind);
               begin
                  if Header.Compressed then
                     Texture.Allocate_Storage (Levels, Header.Compressed_Format,
                       Header.Width);
                  else
                     Texture.Allocate_Storage (Levels, Header.Internal_Format,
                       Header.Width);
                  end if;
                  Resource.Texture.Replace_Element (Texture);
               end;
            when others =>
               raise Program_Error;
         end case;
         T4 := Ada.Real_Time.Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            package Textures renames GL.Objects.Textures;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Image_Size   : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  Padding_Size : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size  : constant Natural := 4 + Image_Size + Padding_Size;

                  Image_Data : aliased Byte_Array := Bytes (Image_Size_Index + 4 .. Image_Size_Index + 4 + Stream_Element_Offset (Image_Size) - 1);

                  procedure Load_1D (Element : Textures.Texture_Base'Class) is
                     Texture : Textures.Texture_1D renames Textures.Texture_1D (Element);
                  begin
                     if Header.Compressed then
                        Texture.Load_From_Compressed_Data (Level, 0, Header.Width,
                          Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data'Address);
                     else
                        Texture.Load_From_Data (Level, 0, Header.Width,
                          Header.Format, Header.Data_Type, Image_Data'Address);
                     end if;
                  end Load_1D;

                  procedure Load_2D (Element : Textures.Texture_Base'Class) is
                     Texture : Textures.Texture_2D renames Textures.Texture_2D (Element);
                  begin
                     if Header.Compressed then
                        Texture.Load_From_Compressed_Data (Level, 0, 0,
                          Header.Width, Header.Height, Header.Compressed_Format,
                          GL.Types.Int (Image_Size), Image_Data'Address);
                     else
                        Texture.Load_From_Data (Level, 0, 0,
                          Header.Width, Header.Height, Header.Format,
                          Header.Data_Type, Image_Data'Address);
                     end if;
                  end Load_2D;

                  procedure Load_3D (Element : Textures.Texture_Base'Class) is
                     Texture : Textures.Texture_3D renames Textures.Texture_3D (Element);
                  begin
                     if Header.Compressed then
                        Texture.Load_From_Compressed_Data (Level, 0, 0, 0,
                          Header.Width, Header.Height, Header.Depth,
                          Header.Compressed_Format, GL.Types.Int (Image_Size),
                          Image_Data'Address);
                        --  TODO For Texture_Cube_Map, Image_Size is the size of one face
                     else
                        Texture.Load_From_Data (Level, 0, 0, 0,
                          Header.Width, Header.Height, Header.Depth, Header.Format,
                          Header.Data_Type, Image_Data'Address);
                     end if;
                  end Load_3D;
               begin
                  case Header.Kind is
                     when Texture_3D | Texture_2D_Array | Texture_Cube_Map_Array =>
                        Resource.Texture.Query_Element (Load_3D'Access);
                     when Texture_2D | Texture_1D_Array | Texture_Cube_Map =>
                        Resource.Texture.Query_Element (Load_2D'Access);
                     when Texture_1D =>
                        Resource.Texture.Query_Element (Load_1D'Access);
                     when others =>
                        raise Program_Error;
                  end case;
                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Ada.Real_Time.Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Resource.Texture.Element.Generate_Mipmap;
         end if;
         T6 := Ada.Real_Time.Clock;

         --  Register resource at the resource manager
         Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));

         declare
            use type Ada.Real_Time.Time;

            Reading_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T2 - T1);
            Parsing_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T3 - T2);
            Storage_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T4 - T3);
            Buffers_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T5 - T4);
            Mipmap_Time  : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T6 - T5);

            Loading_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T6 - T1);
         begin
            Debug_Messages.Insert (GL.Debug.Notification,
               "Loaded texture " & Path);
            Debug_Messages.Insert (GL.Debug.Notification,
               "  width:" & GL.Types.Size'Image (Header.Width) &
               " height:" & GL.Types.Size'Image (Header.Height) &
               " depth:" & GL.Types.Size'Image (Header.Depth) &
               " array length:" & GL.Types.Size'Image (Header.Array_Elements) &
               " mipmap levels:" & GL.Types.Size'Image (Levels));
            if Header.Compressed then
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  compressed format: " & GL.Pixels.Compressed_Format'Image (Header.Compressed_Format));
            else
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  internal: " & GL.Pixels.Internal_Format'Image (Header.Internal_Format));
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  format: " & GL.Pixels.Format'Image (Header.Format));
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  format: " & GL.Pixels.Data_Type'Image (Header.Data_Type));
            end if;

            Debug_Messages.Insert (GL.Debug.Notification,
               "  loaded in" & Duration'Image (Loading_Time) & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    reading file:" & Duration'Image (Reading_Time) & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    parsing header:" & Duration'Image (Parsing_Time) & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    storage:" & Duration'Image (Storage_Time) & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    buffers:" & Duration'Image (Buffers_Time) & " ms");
            if Header.Mipmap_Levels = 0 then
               Debug_Messages.Insert (GL.Debug.Notification,
                  "    generating mipmap:" & Duration'Image (Mipmap_Time) & " ms");
            end if;
         end;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data     => Data,
          Manager  => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

end Orka.Resources.Textures.KTX;

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

with Ada.Exceptions;
with Ada.Real_Time;

with GL.Debug;
with GL.Low_Level.Enums;
with GL.Pixels;
with GL.Types;

with Orka.KTX;
with Orka.Resources.Locations;

package body Orka.Resources.Textures.KTX is

   package Debug_Messages is new GL.Debug.Messages (GL.Debug.Third_Party, GL.Debug.Other);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data    : Loaders.Resource_Data;
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr));

   -----------------------------------------------------------------------------

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Enqueue : not null access procedure (Element : Jobs.Job_Ptr))
   is
      Bytes : Byte_Array_Access renames Object.Data.Bytes;
      Path  : String renames SU.To_String (Object.Data.Path);

      T1 : Ada.Real_Time.Time renames Object.Data.Start_Time;
      T2 : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Resource : constant Texture_Ptr := new Texture'(others => <>);
      begin
         T3 := Ada.Real_Time.Clock;

         --  Allocate storage
         case Header.Kind is
            when Texture_3D | Texture_2D_Array | Texture_Cube_Map_Array =>
               declare
                  Texture : GL.Objects.Textures.Texture_3D (Header.Kind);
               begin
                  if Header.Compressed then
                     Texture.Allocate_Storage (Levels, Header.Compressed_Format,
                       Header.Width, Header.Height, Header.Depth);
                  else
                     Texture.Allocate_Storage (Levels, Header.Internal_Format,
                       Header.Width, Header.Height, Header.Depth);
                  end if;
                  Resource.Texture.Replace_Element (Texture);
               end;
            when Texture_2D | Texture_1D_Array | Texture_Cube_Map =>
               declare
                  Texture : GL.Objects.Textures.Texture_2D (Header.Kind);
               begin
                  if Header.Compressed then
                     Texture.Allocate_Storage (Levels, Header.Compressed_Format,
                       Header.Width, Header.Height);
                  else
                     Texture.Allocate_Storage (Levels, Header.Internal_Format,
                       Header.Width, Header.Height);
                  end if;
                  Resource.Texture.Replace_Element (Texture);
               end;
            when Texture_1D =>
               declare
                  Texture : GL.Objects.Textures.Texture_1D (Header.Kind);
               begin
                  if Header.Compressed then
                     Texture.Allocate_Storage (Levels, Header.Compressed_Format,
                       Header.Width);
                  else
                     Texture.Allocate_Storage (Levels, Header.Internal_Format,
                       Header.Width);
                  end if;
                  Resource.Texture.Replace_Element (Texture);
               end;
            when others =>
               raise Program_Error;
         end case;
         T4 := Ada.Real_Time.Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            package Textures renames GL.Objects.Textures;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Image_Size   : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  Padding_Size : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size  : constant Natural := 4 + Image_Size + Padding_Size;

                  Image_Data : aliased Byte_Array := Bytes (Image_Size_Index + 4 .. Image_Size_Index + 4 + Stream_Element_Offset (Image_Size) - 1);

                  procedure Load_1D (Element : Textures.Texture_Base'Class) is
                     Texture : Textures.Texture_1D renames Textures.Texture_1D (Element);
                  begin
                     if Header.Compressed then
                        Texture.Load_From_Compressed_Data (Level, 0, Header.Width,
                          Header.Compressed_Format, GL.Types.Int (Image_Size),
                          Image_Data'Address);
                     else
                        Texture.Load_From_Data (Level, 0, Header.Width,
                          Header.Format, Header.Data_Type, Image_Data'Address);
                     end if;
                  end Load_1D;

                  procedure Load_2D (Element : Textures.Texture_Base'Class) is
                     Texture : Textures.Texture_2D renames Textures.Texture_2D (Element);
                  begin
                     if Header.Compressed then
                        Texture.Load_From_Compressed_Data (Level, 0, 0,
                          Header.Width, Header.Height, Header.Compressed_Format,
                          GL.Types.Int (Image_Size), Image_Data'Address);
                     else
                        Texture.Load_From_Data (Level, 0, 0,
                          Header.Width, Header.Height, Header.Format,
                          Header.Data_Type, Image_Data'Address);
                     end if;
                  end Load_2D;

                  procedure Load_3D (Element : Textures.Texture_Base'Class) is
                     Texture : Textures.Texture_3D renames Textures.Texture_3D (Element);
                  begin
                     if Header.Compressed then
                        Texture.Load_From_Compressed_Data (Level, 0, 0, 0,
                          Header.Width, Header.Height, Header.Depth,
                          Header.Compressed_Format, GL.Types.Int (Image_Size),
                          Image_Data'Address);
                        --  TODO For Texture_Cube_Map, Image_Size is the size of one face
                     else
                        Texture.Load_From_Data (Level, 0, 0, 0,
                          Header.Width, Header.Height, Header.Depth, Header.Format,
                          Header.Data_Type, Image_Data'Address);
                     end if;
                  end Load_3D;
               begin
                  case Header.Kind is
                     when Texture_3D | Texture_2D_Array | Texture_Cube_Map_Array =>
                        Resource.Texture.Query_Element (Load_3D'Access);
                     when Texture_2D | Texture_1D_Array | Texture_Cube_Map =>
                        Resource.Texture.Query_Element (Load_2D'Access);
                     when Texture_1D =>
                        Resource.Texture.Query_Element (Load_1D'Access);
                     when others =>
                        raise Program_Error;
                  end case;
                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Ada.Real_Time.Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Resource.Texture.Element.Generate_Mipmap;
         end if;
         T6 := Ada.Real_Time.Clock;

         --  Register resource at the resource manager
         Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));

         declare
            use type Ada.Real_Time.Time;

            Reading_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T2 - T1);
            Parsing_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T3 - T2);
            Storage_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T4 - T3);
            Buffers_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T5 - T4);
            Mipmap_Time  : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T6 - T5);

            Loading_Time : constant Duration := 1e3 * Ada.Real_Time.To_Duration (T6 - T1);
         begin
            Debug_Messages.Insert (GL.Debug.Notification,
               "Loaded texture " & Path);
            Debug_Messages.Insert (GL.Debug.Notification,
               "  width:" & Header.Width'Image &
               " height:" & Header.Height'Image &
               " depth:" & Header.Depth'Image &
               " array length:" & Header.Array_Elements'Image &
               " mipmap levels:" & Levels'Image);
            if Header.Compressed then
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  compressed format: " & Header.Compressed_Format'Image);
            else
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  internal: " & Header.Internal_Format'Image);
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  format: " & Header.Format'Image);
               Debug_Messages.Insert (GL.Debug.Notification,
                  "  format: " & Header.Data_Type'Image);
            end if;

            Debug_Messages.Insert (GL.Debug.Notification,
               "  loaded in" & Loading_Time'Image & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    reading file:" & Reading_Time'Image & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    parsing header:" & Parsing_Time'Image & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    storage:" & Storage_Time'Image & " ms");
            Debug_Messages.Insert (GL.Debug.Notification,
               "    buffers:" & Buffers_Time'Image & " ms");
            if Header.Mipmap_Levels = 0 then
               Debug_Messages.Insert (GL.Debug.Notification,
                  "    generating mipmap:" & Mipmap_Time'Image & " ms");
            end if;
         end;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data    => Data,
          Manager => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

end Orka.Resources.Textures.KTX;

orka: Use V'Image instead of T'Image (V) in Orka.Resources.Textures.KTX

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


-----------------------------------------------------------------------
--  security-openid -- OpenID 2.0 Support
--  Copyright (C) 2009, 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.Strings.Fixed;
with Ada.Text_IO;

with Util.Http.Clients;
with Util.Strings;
with Util.Encoders;
with Util.Log.Loggers;
with Util.Encoders.SHA1;
with Util.Encoders.HMAC.SHA1;
package body Security.OpenID is

   use Ada.Strings.Fixed;
   use Util.Log;

   Log : constant Util.Log.Loggers.Logger := Loggers.Create ("Security.OpenID");

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String) is
   begin
      null;
   end Initialize;

end Security.OpenID;

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

package body Security.OpenID is

   --  ------------------------------
   --  Initialize the OpenID realm.
   --  ------------------------------
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String) is
   begin
      null;
   end Initialize;

end Security.OpenID;

Remove unused with clauses

Remove unused with clauses


-----------------------------------------------------------------------
--  security-openid -- Open ID 2.0 Support
--  Copyright (C) 2009, 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.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  There are basically two steps that an application must implement.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The Initialize procedure is called to configure the OpenID realm and set the
--      OpenID return callback CB.
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--    * The Get_Authentication_URL builds the provider OpenID authentication
--      URL for the association.
--    * The application should redirected the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--
--  == Discovery: creating the authentication URL ==
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenId manager, discover the OpenID provider,
--  do the association and get an End_Point.
--
--    Mgr   : Openid.Manager;
--    OP    : Openid.End_Point;
--    Assoc : constant Association_Access := new Association;
--
--  The
--
--    Server.Initialize (Mgr);
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  == Verify: acknowledge the authentication in the callback URL ==
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Mgr     : Openid.Manager;
--    Assoc   : Association_Access := ...;  --  Get the association saved in the session.
--    Auth    : Openid.Authentication;
--    Params  : Auth_Params;
--
--  The OpenID manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Server.Initialize (Mgr);
--    Mgr.Verify (Assoc.all, Params, Auth);
--    if Openid.Get_Status (Auth) /= Openid.AUTHENTICATED then ...  -- Failure.
--
--
--
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

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

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

-----------------------------------------------------------------------
--  security-openid -- Open ID 2.0 Support
--  Copyright (C) 2009, 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.Strings.Unbounded;
with Ada.Calendar;
with Ada.Finalization;

--  == OpenID ==
--  The Security.Openid package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  There are basically two steps that an application must implement:
--
--    * Discovery to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The Initialize procedure is called to configure the OpenID realm and set the
--      OpenID return callback CB.
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--    * The Get_Authentication_URL builds the provider OpenID authentication
--      URL for the association.
--    * The application should redirected the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--
--  == Discovery: creating the authentication URL ==
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenId manager, discover the OpenID provider,
--  do the association and get an End_Point.
--
--    Mgr   : Openid.Manager;
--    OP    : Openid.End_Point;
--    Assoc : constant Association_Access := new Association;
--
--  The
--
--    Server.Initialize (Mgr);
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  == Verify: acknowledge the authentication in the callback URL ==
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Mgr     : Openid.Manager;
--    Assoc   : Association_Access := ...;  --  Get the association saved in the session.
--    Auth    : Openid.Authentication;
--    Params  : Auth_Params;
--
--  The OpenID manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Server.Initialize (Mgr);
--    Mgr.Verify (Assoc.all, Params, Auth);
--    if Openid.Get_Status (Auth) /= Openid.AUTHENTICATED then ...  -- Failure.
--
--
--
package Security.Openid is

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --  The End_Point represents the OpenID provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The OpenID association contains the shared secret between the relying party
   --  and the OpenID provider.  The association can be cached and reused to authenticate
   --  different users using the same OpenID provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  OpenID provider
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  OpenID Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

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

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is tagged limited private;

   --  Initialize the OpenID realm.
   procedure Initialize (Realm     : in out Manager;
                         Name      : in String;
                         Return_To : in String);

   --  Discover the OpenID provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the OpenID provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

   --  Verify the authentication result
   procedure Verify_Discovered (Realm   : in out Manager;
                                Assoc   : in Association;
                                Request : in Parameters'Class;
                                Result  : out Authentication);

   --  Verify the signature part of the result
   procedure Verify_Signature (Realm   : in Manager;
                               Assoc   : in Association;
                               Request : in Parameters'Class;
                               Result  : in out Authentication);

   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   procedure Discover_XRDS (Realm  : in out Manager;
                            URI    : in String;
                            Result : out End_Point);

   --  Extract from the XRDS content the OpenID provider URI.
   --  The default implementation is very basic as it returns the first <URI>
   --  available in the stream without validating the XRDS document.
   --  Raises the Invalid_End_Point exception if the URI cannot be found.
   procedure Extract_XRDS (Realm   : in out Manager;
                           Content : in String;
                           Result  : out End_Point);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Realm     : Unbounded_String;
      Return_To : Unbounded_String;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

Update the documentation

Update the documentation


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

      procedure Update (Id      : in Event_Id_Type;
                        Process : not null access procedure (Event : in out Probe_Event_Type));

      --  ------------------------------
      --  Internal operation to update the event represented by <tt>Id</tt>.
      --  ------------------------------
      procedure Update (Id      : in Event_Id_Type;
                        Process : not null access procedure (Event : in out Probe_Event_Type)) is
         Iter  : constant Event_Id_Cursor := Ids.Floor (Id);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
      begin
         if Event_Id_Maps.Has_Element (Iter) then
            Block := Event_Id_Maps.Element (Iter);
            Pos := Id - Block.Events (Block.Events'First).Id + Block.Events'First;
            if Pos <= Block.Count then
               Process (Block.Events (Pos));
            end if;
         end if;
      end Update;

      --  ------------------------------
      --  Update the Size and Prev_Id information in the event identified by <tt>Id</tt>.
      --  Update the event represented by <tt>Prev_Id</tt> so that its Next_Id refers
      --  to the <tt>Id</tt> event.
      --  ------------------------------
      procedure Update_Event (Id      : in Event_Id_Type;
                              Size    : in MAT.Types.Target_Size;
                              Prev_Id : in Event_Id_Type) is
         procedure Update_Size (Event : in out Probe_Event_Type);
         procedure Update_Next (Event : in out Probe_Event_Type);

         procedure Update_Size (Event : in out Probe_Event_Type) is
         begin
            Event.Size    := Size;
            Event.Prev_Id := Prev_Id;
         end Update_Size;

         procedure Update_Next (Event : in out Probe_Event_Type) is
         begin
            Event.Next_Id := Id;
         end Update_Next;

      begin
         Update (Id, Update_Size'Access);
         Update (Prev_Id, Update_Next'Access);
      end Update_Event;

      --  ------------------------------
      --  Add the event in the list of events.
      --  ------------------------------
      procedure Insert (Event : in Probe_Event_Type) is
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
            Ids.Insert (Last_Id, 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;

-----------------------------------------------------------------------
--  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.
   --  Update the event instance to allocate the event Id.
   --  ------------------------------
   procedure Insert (Target : in out Target_Events;
                     Event  : in out 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

      procedure Update (Id      : in Event_Id_Type;
                        Process : not null access procedure (Event : in out Probe_Event_Type));

      --  ------------------------------
      --  Internal operation to update the event represented by <tt>Id</tt>.
      --  ------------------------------
      procedure Update (Id      : in Event_Id_Type;
                        Process : not null access procedure (Event : in out Probe_Event_Type)) is
         Iter  : constant Event_Id_Cursor := Ids.Floor (Id);
         Block : Event_Block_Access;
         Pos   : Event_Id_Type;
      begin
         if Event_Id_Maps.Has_Element (Iter) then
            Block := Event_Id_Maps.Element (Iter);
            Pos := Id - Block.Events (Block.Events'First).Id + Block.Events'First;
            if Pos <= Block.Count then
               Process (Block.Events (Pos));
            end if;
         end if;
      end Update;

      --  ------------------------------
      --  Update the Size and Prev_Id information in the event identified by <tt>Id</tt>.
      --  Update the event represented by <tt>Prev_Id</tt> so that its Next_Id refers
      --  to the <tt>Id</tt> event.
      --  ------------------------------
      procedure Update_Event (Id      : in Event_Id_Type;
                              Size    : in MAT.Types.Target_Size;
                              Prev_Id : in Event_Id_Type) is
         procedure Update_Size (Event : in out Probe_Event_Type);
         procedure Update_Next (Event : in out Probe_Event_Type);

         procedure Update_Size (Event : in out Probe_Event_Type) is
         begin
            Event.Size    := Size;
            Event.Prev_Id := Prev_Id;
         end Update_Size;

         procedure Update_Next (Event : in out Probe_Event_Type) is
         begin
            Event.Next_Id := Id;
         end Update_Next;

      begin
         Update (Id, Update_Size'Access);
         Update (Prev_Id, Update_Next'Access);
      end Update_Event;

      --  ------------------------------
      --  Add the event in the list of events.
      --  Update the event instance to allocate the event Id.
      --  ------------------------------
      procedure Insert (Event : in out Probe_Event_Type) is
      begin
         if Current = null then
            Current := new Event_Block;
            Current.Start := Event.Time;
            Events.Insert (Event.Time, Current);
            Ids.Insert (Last_Id, 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;

Change the Insert procedure to update the Event.Id after the insertion


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

with Util.Tests;
with Util.Tests.Servers;
with Util.Streams.Texts;
with Util.Streams.Sockets;
package Util.Http.Clients.Tests is

   type Method_Type is (OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT, UNKNOWN);

   type Test_Server is new Util.Tests.Servers.Server with record
      Method       : Method_Type := UNKNOWN;
      Result       : Ada.Strings.Unbounded.Unbounded_String;
      Content_Type : Ada.Strings.Unbounded.Unbounded_String;
      Length       : Natural := 0;
   end record;
   type Test_Server_Access is access all Test_Server'Class;

   --  Process the line received by the server.
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class);

   type Test is new Util.Tests.Test with record
      Server : Test_Server_Access := null;
   end record;

   --  Test the http Get operation.
   procedure Test_Http_Get (T : in out Test);

   --  Test the http POST operation.
   procedure Test_Http_Post (T : in out Test);

   overriding
   procedure Set_Up (T : in out Test);

   overriding
   procedure Tear_Down (T : in out Test);

   --  Get the test server base URI.
   function Get_Uri (T : in Test) return String;

   --  The Http_Tests package must be instantiated with one of the HTTP implementation.
   --  The Register procedure configures the Http.Client to use the given HTTP
   --  implementation before running the test.
   generic
      with procedure Register;
      NAME : in String;
   package Http_Tests is
      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

      type Http_Test is new Test with null record;

      overriding
      procedure Set_Up (T : in out Http_Test);

   end Http_Tests;

end Util.Http.Clients.Tests;

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

with Util.Tests;
with Util.Tests.Servers;
with Util.Streams.Texts;
with Util.Streams.Sockets;
package Util.Http.Clients.Tests is

   type Method_Type is (OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT, UNKNOWN);

   type Test_Server is new Util.Tests.Servers.Server with record
      Method       : Method_Type := UNKNOWN;
      Result       : Ada.Strings.Unbounded.Unbounded_String;
      Content_Type : Ada.Strings.Unbounded.Unbounded_String;
      Length       : Natural := 0;
   end record;
   type Test_Server_Access is access all Test_Server'Class;

   --  Process the line received by the server.
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class);

   type Test is new Util.Tests.Test with record
      Server : Test_Server_Access := null;
   end record;

   --  Test the http Get operation.
   procedure Test_Http_Get (T : in out Test);

   --  Test the http POST operation.
   procedure Test_Http_Post (T : in out Test);

   --  Test the http PUT operation.
   procedure Test_Http_Put (T : in out Test);

   --  Test the http DELETE operation.
   procedure Test_Http_Delete (T : in out Test);

   overriding
   procedure Set_Up (T : in out Test);

   overriding
   procedure Tear_Down (T : in out Test);

   --  Get the test server base URI.
   function Get_Uri (T : in Test) return String;

   --  The Http_Tests package must be instantiated with one of the HTTP implementation.
   --  The Register procedure configures the Http.Client to use the given HTTP
   --  implementation before running the test.
   generic
      with procedure Register;
      NAME : in String;
   package Http_Tests is
      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

      type Http_Test is new Test with null record;

      overriding
      procedure Set_Up (T : in out Http_Test);

   end Http_Tests;

end Util.Http.Clients.Tests;

Declare Test_Http_Put and Test_Http_Delete