--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2020 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.Characters.Latin_1;
with Ada.Numerics.Generic_Elementary_Functions;

with GL.Buffers;

with Orka.Rendering.Drawing;
with Orka.Transforms.Doubles.Matrices;
with Orka.Transforms.Doubles.Vectors;
with Orka.Transforms.Doubles.Vector_Conversions;
with Orka.Transforms.Singles.Vectors;

package body Orka.Features.Atmosphere.Rendering is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (GL.Types.Double);

   Altitude_Hack_Threshold : constant := 8000.0;

   function Create_Atmosphere
     (Data       : aliased Model_Data;
      Location   : Resources.Locations.Location_Ptr;
      Parameters : Model_Parameters := (others => <>)) return Atmosphere
   is
      Atmosphere_Model : constant Model := Create_Model (Data'Access, Location);

      Sky_GLSL : constant String := Resources.Convert
        (Orka.Resources.Byte_Array'(Location.Read_Data ("atmosphere/sky.frag").Get));

      use Ada.Characters.Latin_1;
      use Rendering.Programs;
      use Rendering.Programs.Modules;

      Sky_Shader : constant String :=
        "#version 420 core" & LF &
        (if Data.Luminance /= None then "#define USE_LUMINANCE" & LF else "") &
        "const float kLengthUnitInMeters = " & Data.Length_Unit_In_Meters'Image & ";" & LF &
        Sky_GLSL & LF;

      Shader_Module : constant Rendering.Programs.Modules.Module := Atmosphere_Model.Get_Shader;
   begin
      return Result : Atmosphere :=
        (Program => Create_Program (Modules.Module_Array'
           (Modules.Create_Module (Location, VS => "atmosphere/sky.vert"),
            Modules.Create_Module_From_Sources (FS => Sky_Shader),
            Shader_Module)),
         Module  => Shader_Module,
         Parameters     => Parameters,
         Bottom_Radius  => Data.Bottom_Radius,
         Distance_Scale => 1.0 / Data.Length_Unit_In_Meters,
         others => <>)
      do
         Result.Uniform_Ground_Hack   := Result.Program.Uniform ("ground_hack");
         Result.Uniform_Camera_Offset := Result.Program.Uniform ("camera_offset");

         Result.Uniform_Camera_Pos := Result.Program.Uniform ("camera_pos");
         Result.Uniform_Planet_Pos := Result.Program.Uniform ("planet_pos");

         Result.Uniform_View := Result.Program.Uniform ("view");
         Result.Uniform_Proj := Result.Program.Uniform ("proj");

         Result.Uniform_Sun_Dir  := Result.Program.Uniform ("sun_direction");

         Result.Uniform_Star_Dir  := Result.Program.Uniform ("star_direction");
         Result.Uniform_Star_Size := Result.Program.Uniform ("star_size");
      end return;
   end Create_Atmosphere;

   function Shader_Module (Object : Atmosphere) return Orka.Rendering.Programs.Modules.Module is
     (Object.Module);

   function Flattened_Vector
     (Parameters : Model_Parameters;
      Direction  : Orka.Transforms.Doubles.Vectors.Vector4)
   return Orka.Transforms.Doubles.Vectors.Vector4 is
      Altitude   : constant := 0.0;
      Flattening : GL.Types.Double renames Parameters.Flattening;

      E2 : constant GL.Types.Double := 2.0 * Flattening - Flattening**2;

      N : constant GL.Types.Double := Parameters.Semi_Major_Axis /
        EF.Sqrt (1.0 - E2 * Direction (Orka.Z)**2);
   begin
      return
        (Direction (Orka.X) * (N + Altitude),
         Direction (Orka.Y) * (N + Altitude),
         Direction (Orka.Z) * (N * (1.0 - E2) + Altitude),
         1.0);
   end Flattened_Vector;

   package Matrices renames Orka.Transforms.Doubles.Matrices;

   procedure Render
     (Object : in out Atmosphere;
      Camera : Cameras.Camera_Ptr;
      Planet : Behaviors.Behavior_Ptr;
      Star   : Behaviors.Behavior_Ptr)
   is
      function "*" (Left : Matrices.Matrix4; Right : Matrices.Vector4) return Matrices.Vector4
        renames Matrices."*";

      function "*" (Left, Right : Matrices.Matrix4) return Matrices.Matrix4 renames Matrices."*";

      function Far_Plane (Value : GL.Types.Compare_Function) return GL.Types.Compare_Function is
        (case Value is
           when Less | LEqual     => LEqual,
           when Greater | GEqual  => GEqual,
           when others            => raise Constraint_Error);

      Original_Function : constant GL.Types.Compare_Function := GL.Buffers.Depth_Function;

      use Orka.Transforms.Doubles.Vectors;
      use Orka.Transforms.Doubles.Vector_Conversions;

      use all type Orka.Transforms.Doubles.Vectors.Vector4;

      Planet_To_Camera : constant Vector4 := Camera.View_Position - Planet.Position;
      Planet_To_Star   : constant Vector4 := Star.Position - Planet.Position;
      Camera_To_Star   : constant Vector4 := Star.Position - Camera.View_Position;

      procedure Apply_Hacks is
         GL_To_Geo : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 1.0, 1.0, 0.0)),
            (2.0 / 3.0) * Ada.Numerics.Pi);
         Earth_Tilt : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 0.0, 0.0, 0.0)),
            Object.Parameters.Axial_Tilt);

         Inverse_Inertial    : constant Matrices.Matrix4 := Earth_Tilt * GL_To_Geo;
         Camera_Normal_Inert : constant Vector4 := Normalize (Inverse_Inertial * Planet_To_Camera);

         Actual_Surface   : constant Vector4 := Flattened_Vector
           (Object.Parameters, Camera_Normal_Inert);
         Expected_Surface : constant Vector4 := Camera_Normal_Inert * Object.Bottom_Radius;

         Offset   : constant Vector4 := Expected_Surface - Actual_Surface;
         Altitude : constant Double  := Length (Planet_To_Camera) - Length (Actual_Surface);
      begin
         Object.Uniform_Ground_Hack.Set_Boolean (Altitude < Altitude_Hack_Threshold);
         Object.Uniform_Camera_Offset.Set_Vector (Convert (Offset * Object.Distance_Scale));
      end Apply_Hacks;
   begin
      if Object.Parameters.Flattening > 0.0 then
         Apply_Hacks;
      else
         Object.Uniform_Ground_Hack.Set_Boolean (False);
         Object.Uniform_Camera_Offset.Set_Vector (Orka.Transforms.Singles.Vectors.Zero);
      end if;

      Object.Uniform_Camera_Pos.Set_Vector (Orka.Transforms.Singles.Vectors.Zero);
      Object.Uniform_Planet_Pos.Set_Vector (Convert (-Planet_To_Camera * Object.Distance_Scale));

      Object.Uniform_Sun_Dir.Set_Vector (Convert (Normalize (Planet_To_Star)));
      Object.Uniform_Star_Dir.Set_Vector (Convert (Normalize (Camera_To_Star)));

      --  Use distance to star and its radius instead of the
      --  Sun_Angular_Radius of Model_Data
      declare
         Angular_Radius : constant GL.Types.Double :=
           EF.Arctan (Object.Parameters.Star_Radius, Length (Camera_To_Star));
      begin
         Object.Uniform_Star_Size.Set_Single (GL.Types.Single (EF.Cos (Angular_Radius)));
      end;

      Object.Uniform_View.Set_Matrix (Camera.View_Matrix);
      Object.Uniform_Proj.Set_Matrix (Camera.Projection_Matrix);

      Object.Program.Use_Program;

      GL.Buffers.Set_Depth_Function (Far_Plane (Original_Function));
      Orka.Rendering.Drawing.Draw (GL.Types.Triangles, 0, 3);
      GL.Buffers.Set_Depth_Function (Original_Function);
   end Render;

end Orka.Features.Atmosphere.Rendering;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2020 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.Characters.Latin_1;
with Ada.Numerics.Generic_Elementary_Functions;

with GL.Buffers;

with Orka.Rendering.Drawing;
with Orka.Transforms.Doubles.Matrices;
with Orka.Transforms.Doubles.Vectors;
with Orka.Transforms.Doubles.Vector_Conversions;
with Orka.Transforms.Singles.Vectors;

package body Orka.Features.Atmosphere.Rendering is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (GL.Types.Double);

   Altitude_Hack_Threshold : constant := 8000.0;

   function Create_Atmosphere
     (Data       : aliased Model_Data;
      Location   : Resources.Locations.Location_Ptr;
      Parameters : Model_Parameters := (others => <>)) return Atmosphere
   is
      Atmosphere_Model : constant Model := Create_Model (Data'Access, Location);

      Sky_GLSL : constant String := Resources.Convert
        (Orka.Resources.Byte_Array'(Location.Read_Data ("atmosphere/sky.frag").Get));

      use Ada.Characters.Latin_1;
      use Rendering.Programs;
      use Rendering.Programs.Modules;

      Sky_Shader : constant String :=
        "#version 420 core" & LF &
        (if Data.Luminance /= None then "#define USE_LUMINANCE" & LF else "") &
        "const float kLengthUnitInMeters = " & Data.Length_Unit_In_Meters'Image & ";" & LF &
        Sky_GLSL & LF;

      Shader_Module : constant Rendering.Programs.Modules.Module := Atmosphere_Model.Get_Shader;
   begin
      return Result : Atmosphere :=
        (Program => Create_Program (Modules.Module_Array'
           (Modules.Create_Module (Location, VS => "atmosphere/sky.vert"),
            Modules.Create_Module_From_Sources (FS => Sky_Shader),
            Shader_Module)),
         Module  => Shader_Module,
         Parameters     => Parameters,
         Bottom_Radius  => Data.Bottom_Radius,
         Distance_Scale => 1.0 / Data.Length_Unit_In_Meters,
         others => <>)
      do
         Result.Uniform_Ground_Hack   := Result.Program.Uniform ("ground_hack");
         Result.Uniform_Camera_Offset := Result.Program.Uniform ("camera_offset");

         Result.Uniform_Camera_Pos := Result.Program.Uniform ("camera_pos");
         Result.Uniform_Planet_Pos := Result.Program.Uniform ("planet_pos");

         Result.Uniform_View := Result.Program.Uniform ("view");
         Result.Uniform_Proj := Result.Program.Uniform ("proj");

         Result.Uniform_Sun_Dir  := Result.Program.Uniform ("sun_direction");

         Result.Uniform_Star_Dir  := Result.Program.Uniform ("star_direction");
         Result.Uniform_Star_Size := Result.Program.Uniform ("star_size");
      end return;
   end Create_Atmosphere;

   function Shader_Module (Object : Atmosphere) return Orka.Rendering.Programs.Modules.Module is
     (Object.Module);

   function Flattened_Vector
     (Parameters : Model_Parameters;
      Direction  : Orka.Transforms.Doubles.Vectors.Vector4)
   return Orka.Transforms.Doubles.Vectors.Vector4 is
      Altitude   : constant := 0.0;
      Flattening : GL.Types.Double renames Parameters.Flattening;

      E2 : constant GL.Types.Double := 2.0 * Flattening - Flattening**2;

      N : constant GL.Types.Double := Parameters.Semi_Major_Axis /
        EF.Sqrt (1.0 - E2 * Direction (Orka.Z)**2);
   begin
      return
        (Direction (Orka.X) * (N + Altitude),
         Direction (Orka.Y) * (N + Altitude),
         Direction (Orka.Z) * (N * (1.0 - E2) + Altitude),
         1.0);
   end Flattened_Vector;

   package Matrices renames Orka.Transforms.Doubles.Matrices;

   procedure Render
     (Object : in out Atmosphere;
      Camera : Cameras.Camera_Ptr;
      Planet : Behaviors.Behavior_Ptr;
      Star   : Behaviors.Behavior_Ptr)
   is
      function "*" (Left : Matrices.Matrix4; Right : Matrices.Vector4) return Matrices.Vector4
        renames Matrices."*";

      function "*" (Left, Right : Matrices.Matrix4) return Matrices.Matrix4 renames Matrices."*";

      function Far_Plane (Value : GL.Types.Compare_Function) return GL.Types.Compare_Function is
        (case Value is
           when Less | LEqual     => LEqual,
           when Greater | GEqual  => GEqual,
           when others            => raise Constraint_Error);

      Original_Function : constant GL.Types.Compare_Function := GL.Buffers.Depth_Function;

      use Orka.Transforms.Doubles.Vectors;
      use Orka.Transforms.Doubles.Vector_Conversions;

      use all type Orka.Transforms.Doubles.Vectors.Vector4;

      Planet_To_Camera : constant Vector4 := Camera.View_Position - Planet.Position;
      Planet_To_Star   : constant Vector4 := Star.Position - Planet.Position;
      Camera_To_Star   : constant Vector4 := Star.Position - Camera.View_Position;

      procedure Apply_Hacks is
         GL_To_Geo : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 1.0, 1.0, 0.0)),
            (2.0 / 3.0) * Ada.Numerics.Pi);
         Earth_Tilt : constant Matrices.Matrix4 := Matrices.R
           (Matrices.Vectors.Normalize ((1.0, 0.0, 0.0, 0.0)),
            Object.Parameters.Axial_Tilt);

         Inverse_Inertial    : constant Matrices.Matrix4 := Earth_Tilt * GL_To_Geo;
         Camera_Normal_Inert : constant Vector4 := Normalize (Inverse_Inertial * Planet_To_Camera);

         Actual_Surface   : constant Vector4 := Flattened_Vector
           (Object.Parameters, Camera_Normal_Inert);
         Expected_Surface : constant Vector4 := Camera_Normal_Inert * Object.Bottom_Radius;

         Offset   : constant Vector4 := Expected_Surface - Actual_Surface;
         Altitude : constant Double  := Length (Planet_To_Camera) - Length (Actual_Surface);
      begin
         Object.Uniform_Ground_Hack.Set_Boolean (Altitude < Altitude_Hack_Threshold);
         Object.Uniform_Camera_Offset.Set_Vector (Convert (Offset * Object.Distance_Scale));
      end Apply_Hacks;
   begin
      if Object.Parameters.Flattening > 0.0 then
         Apply_Hacks;
      else
         Object.Uniform_Ground_Hack.Set_Boolean (False);
         Object.Uniform_Camera_Offset.Set_Vector (Orka.Transforms.Singles.Vectors.Zero_Vector);
      end if;

      Object.Uniform_Camera_Pos.Set_Vector (Orka.Transforms.Singles.Vectors.Zero_Vector);
      Object.Uniform_Planet_Pos.Set_Vector (Convert (-Planet_To_Camera * Object.Distance_Scale));

      Object.Uniform_Sun_Dir.Set_Vector (Convert (Normalize (Planet_To_Star)));
      Object.Uniform_Star_Dir.Set_Vector (Convert (Normalize (Camera_To_Star)));

      --  Use distance to star and its radius instead of the
      --  Sun_Angular_Radius of Model_Data
      declare
         Angular_Radius : constant GL.Types.Double :=
           EF.Arctan (Object.Parameters.Star_Radius, Length (Camera_To_Star));
      begin
         Object.Uniform_Star_Size.Set_Single (GL.Types.Single (EF.Cos (Angular_Radius)));
      end;

      Object.Uniform_View.Set_Matrix (Camera.View_Matrix);
      Object.Uniform_Proj.Set_Matrix (Camera.Projection_Matrix);

      Object.Program.Use_Program;

      GL.Buffers.Set_Depth_Function (Far_Plane (Original_Function));
      Orka.Rendering.Drawing.Draw (GL.Types.Triangles, 0, 3);
      GL.Buffers.Set_Depth_Function (Original_Function);
   end Render;

end Orka.Features.Atmosphere.Rendering;

atmosphere: Fix compilation after renaming function to a constant

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


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

with Util.Strings;
with Util.Beans.Objects;

with ASF.Utils;

--  The <b>Pages</b> package implements various components used when building an HTML page.
--
package body ASF.Components.Html.Pages is

   BODY_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   HEAD_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Head Component
   --  ------------------------------

   --  ------------------------------
   --  Encode the HTML head element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIHead;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("head");
      UI.Render_Attributes (Context, HEAD_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML head element.  Before closing the head, generate the resource
   --  links that have been queued for the head generation.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIHead;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("head");
   end Encode_End;

   --  ------------------------------
   --  Encode the HTML body element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIBody;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("body");
      UI.Render_Attributes (Context, BODY_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML body element.  Before closing the body, generate the inclusion
   --  of differed resources (pending javascript, inclusion of javascript files)
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIBody;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("body");
   end Encode_End;

   --  ------------------------------
   --  Encode the DOCTYPE element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIDoctype;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.Write ("<!DOCTYPE ");
         Writer.Write (UI.Get_Attribute ("rootElement", Context, ""));
         declare
            Public : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "public");
            System : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "system");
         begin
            if not Util.Beans.Objects.Is_Null (Public) then
               Writer.Write (" PUBLIC """);
               Writer.Write (Public);
               Writer.Write ('"');
            end if;
            if not Util.Beans.Objects.Is_Null (System) then
               Writer.Write (" """);
               Writer.Write (System);
               Writer.Write ('"');
            end if;
         end;
         Writer.Write ('>');
         Writer.Write (ASCII.LF);
      end if;
   end Encode_Begin;

begin
   Utils.Set_Head_Attributes (HEAD_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (BODY_ATTRIBUTE_NAMES);
   Utils.Set_Body_Attributes (BODY_ATTRIBUTE_NAMES);
end ASF.Components.Html.Pages;

-----------------------------------------------------------------------
--  html-pages -- HTML Page Components
--  Copyright (C) 2011, 2014, 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 Util.Strings;
with Util.Beans.Objects;

with ASF.Utils;
with ASF.Requests;

--  The Pages package implements various components used when building an HTML page.
--
package body ASF.Components.Html.Pages is

   BODY_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   HEAD_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Head Component
   --  ------------------------------

   --  ------------------------------
   --  Encode the HTML head element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIHead;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("head");
      UI.Render_Attributes (Context, HEAD_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML head element.  Before closing the head, generate the resource
   --  links that have been queued for the head generation.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIHead;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("head");
   end Encode_End;

   --  ------------------------------
   --  Encode the HTML body element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIBody;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("body");
      UI.Render_Attributes (Context, BODY_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML body element.  Before closing the body, generate the inclusion
   --  of differed resources (pending javascript, inclusion of javascript files)
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIBody;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("body");
   end Encode_End;

   --  ------------------------------
   --  Get the link to be rendered in the href attribute.
   --  ------------------------------
   function Get_Link (UI      : in UIOutputStylesheet;
                      Context : in Faces_Context'Class) return String is
      Req   : constant ASF.Requests.Request_Access := Context.Get_Request;
      Name  : constant String := UI.Get_Attribute ("name", Context,  "");
      Lib   : constant String := UI.Get_Attribute ("library", Context,  "");
      Ctx   : constant String := Req.Get_Context_Path;
   begin
      if Lib'Length > 0 then
         return Ctx & "/resources/" & Lib & "/" & Name;
      else
         return Ctx & "/resources/" & Name;
      end if;
   end Get_Link;

   --  ------------------------------
   --  Terminate the HTML body element.  Before closing the body, generate the inclusion
   --  of differed resources (pending javascript, inclusion of javascript files)
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIOutputStylesheet;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if not UI.Is_Rendered (Context) then
         return;
      end if;
      Writer.Start_Element ("link");
      Writer.Write_Attribute ("type", "text/css");
      Writer.Write_Attribute ("rel", "stylesheet");
      Writer.Write_Attribute ("href", UI.Get_Link (Context));
      Writer.End_Element ("link");
   end Encode_End;

   --  ------------------------------
   --  Encode the DOCTYPE element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIDoctype;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.Write ("<!DOCTYPE ");
         Writer.Write (UI.Get_Attribute ("rootElement", Context, ""));
         declare
            Public : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "public");
            System : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "system");
         begin
            if not Util.Beans.Objects.Is_Null (Public) then
               Writer.Write (" PUBLIC """);
               Writer.Write (Public);
               Writer.Write ('"');
            end if;
            if not Util.Beans.Objects.Is_Null (System) then
               Writer.Write (" """);
               Writer.Write (System);
               Writer.Write ('"');
            end if;
         end;
         Writer.Write ('>');
         Writer.Write (ASCII.LF);
      end if;
   end Encode_Begin;

begin
   Utils.Set_Head_Attributes (HEAD_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (BODY_ATTRIBUTE_NAMES);
   Utils.Set_Body_Attributes (BODY_ATTRIBUTE_NAMES);
end ASF.Components.Html.Pages;

Implement Encode_End and Get_Link for UIOutputStylesheet type


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

--  == Introduction ==
--  The <tt>Security</tt> package provides security frameworks that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

end Security;

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

--  == Introduction ==
--  The <tt>Security</tt> package provides security frameworks that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;
--
--     --  Returns true if the given role is stored in the user principal.
--     function Has_Role (User : in Principal;
--                        Role : in Role_Type) return Boolean is abstract;

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

end Security;

Move the Principal to the Security package


-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
private with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns True if the source string starts with the given prefix.
   function Starts_With (Source  : in String;
                         Prefix  : in String) return Boolean;

   --  Returns True if the source string ends with the given suffix.
   function Ends_With (Source  : in String;
                       Suffix  : in String) return Boolean;

   --  Returns True if the source contains the pattern.
   function Contains (Source  : in String;
                      Pattern : in String) return Boolean;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017, 2022 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;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
private with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns True if the source string starts with the given prefix.
   function Starts_With (Source  : in String;
                         Prefix  : in String) return Boolean;

   --  Returns True if the source string ends with the given suffix.
   function Ends_With (Source  : in String;
                       Suffix  : in String) return Boolean;

   --  Returns True if the source contains the pattern.
   function Contains (Source  : in String;
                      Pattern : in String) return Boolean;

   --  Simple string replacement within the source of the specified content
   --  by another string.  By default, replace only the first sequence.
   function Replace (Source  : in String;
                     Content : in String;
                     By      : in String;
                     First   : in Boolean := True) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

Add the Replace function to replace a content by another one


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

with Security.Permissions;

--  == 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
--
--  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.
--
--  There are basically two steps that an application must implement.
--
--  == Step 1: 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);
--
--  == Step 2: verify 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.Permissions.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

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

with Security.Permissions;

--  == 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
--
--  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.
--
--  There are basically two steps that an application must implement.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  == Step 1: 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);
--
--  == Step 2: verify 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.Permissions.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Permissions.Role_Type) return Boolean;

   --  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.Permissions.Principal with record
      Auth : Authentication;
   end record;

end Security.Openid;

Add picture

Add picture


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

   use type Ada.Real_Time.Time;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Timer_Node,
                                     Name   => Timer_Node_Access);

   --  -----------------------
   --  Repeat the timer.
   --  -----------------------
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span) is
      Timer : constant Timer_Node_Access := Event.Value;
   begin
      if Timer /= null and then Timer.List /= null then
         Timer.List.Add (Timer, Timer.Deadline + In_Time);
      end if;
   end Repeat;

   --  -----------------------
   --  Cancel the timer.
   --  -----------------------
   procedure Cancel (Event : in out Timer_Ref) is
   begin
      if Event.Value /= null and then Event.Value.List /= null then
         Event.Value.List.all.Cancel (Event.Value);
         Event.Value.List := null;
      end if;
   end Cancel;

   --  -----------------------
   --  Check if the timer is ready to be executed.
   --  -----------------------
   function Is_Scheduled (Event : in Timer_Ref) return Boolean is
   begin
      return Event.Value /= null and then Event.Value.List /= null;
   end Is_Scheduled;

   --  -----------------------
   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   --  -----------------------
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time is
   begin
      return (if Event.Value /= null then Event.Value.Deadline else Ada.Real_Time.Time_Last);
   end Time_Of_Event;

   --  -----------------------
   --  Set a timer to be called at the given time.
   --  -----------------------
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time) is
      Timer : Timer_Node_Access := Event.Value;
   begin
      if Timer = null then
         Event.Value := new Timer_Node;
         Timer := Event.Value;
      end if;
      Timer.Handler := Handler;

      --  Cancel the timer if it is part of another timer manager.
      if Timer.List /= null and Timer.List /= List.Manager'Unchecked_Access then
         Timer.List.Cancel (Timer);
      end if;

      --  Update the timer.
      Timer.List := List.Manager'Unchecked_Access;
      List.Manager.Add (Timer, At_Time);
   end Set_Timer;

   --  -----------------------
   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   --  -----------------------
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last) is
      Timer : Timer_Ref;
      Now   : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      loop
         Timer.Finalize;
         List.Manager.Find_Next (Now, Timeout, Timer);
         exit when not Timer.Is_Scheduled;
         Timer.Value.Handler.Time_Handler (Timer);
      end loop;
   end Process;

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

   overriding
   procedure Finalize (Object : in out Timer_Ref) is
      Is_Zero : Boolean;
   begin
      if Object.Value /= null then
         Util.Concurrent.Counters.Decrement (Object.Value.Counter, Is_Zero);
         if Is_Zero then
            Free (Object.Value);
         else
            Object.Value := null;
         end if;
      end if;
   end Finalize;

   protected body Timer_Manager is

      procedure Remove (Timer : in Timer_Node_Access) is
      begin
         if List = Timer then
            List := Timer.Next;
            Timer.Prev := null;
            if List /= null then
               List.Prev := null;
            end if;
         elsif Timer.Prev /= null then
            Timer.Prev.Next := Timer.Next;
            Timer.Next.Prev := Timer.Prev;
         else
            return;
         end if;
         Timer.Next := null;
         Timer.Prev := null;
         Timer.List := null;
      end Remove;

      --  -----------------------
      --  Add a timer.
      --  -----------------------
      procedure Add (Timer    : in Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time) is
         Current : Timer_Node_Access := List;
         Prev    : Timer_Node_Access;
      begin
         Util.Concurrent.Counters.Increment (Timer.Counter);
         if Timer.List /= null then
            Remove (Timer);
         end if;
         Timer.Deadline := Deadline;
         while Current /= null loop
            if Current.Deadline < Deadline then
               if Prev = null then
                  List := Timer;
               else
                  Prev.Next := Timer;
               end if;
               Timer.Next := Current;
               Current.Prev := Timer;
               return;
            end if;
            Prev := Current;
            Current := Current.Next;
         end loop;
         if Prev = null then
            List := Timer;
            Timer.Prev := null;
         else
            Prev.Next := Timer;
            Timer.Prev := Prev;
         end if;
         Timer.Next := null;
      end Add;

      --  -----------------------
      --  Cancel a timer.
      --  -----------------------
      procedure Cancel (Timer : in out Timer_Node_Access) is
         Is_Zero : Boolean;
      begin
         if Timer.List = null then
            return;
         end if;
         Remove (Timer);
         Util.Concurrent.Counters.Decrement (Timer.Counter, Is_Zero);
         if Is_Zero then
            Free (Timer);
         end if;
      end Cancel;

      --  -----------------------
      --  Find the next timer to be executed before the given time or return the next deadline.
      --  -----------------------
      procedure Find_Next (Before   : in Ada.Real_Time.Time;
                           Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref) is
      begin
         if List = null then
            Deadline := Ada.Real_Time.Time_Last;
         elsif List.Deadline < Before then
            Timer.Value := List;
            List := List.Next;
            if List /= null then
               List.Prev := null;
               Deadline := List.Deadline;
            else
               Deadline := Ada.Real_Time.Time_Last;
            end if;
         else
            Deadline := List.Deadline;
         end if;
      end Find_Next;

   end Timer_Manager;

   overriding
   procedure Finalize (Object : in out Timer_List) is
      Timer    : Timer_Ref;
      Timeout  : Ada.Real_Time.Time;
   begin
      loop
         Object.Manager.Find_Next (Ada.Real_Time.Time_Last, Timeout, Timer);
         exit when Timer.Value = null;
         Timer.Finalize;
      end loop;
   end Finalize;

end Util.Events.Timers;

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

   use type Ada.Real_Time.Time;

   procedure Free is
     new Ada.Unchecked_Deallocation (Object => Timer_Node,
                                     Name   => Timer_Node_Access);

   --  -----------------------
   --  Repeat the timer.
   --  -----------------------
   procedure Repeat (Event   : in out Timer_Ref;
                     In_Time : in Ada.Real_Time.Time_Span) is
      Timer : constant Timer_Node_Access := Event.Value;
   begin
      if Timer /= null and then Timer.List /= null then
         Timer.List.Add (Timer, Timer.Deadline + In_Time);
      end if;
   end Repeat;

   --  -----------------------
   --  Cancel the timer.
   --  -----------------------
   procedure Cancel (Event : in out Timer_Ref) is
   begin
      if Event.Value /= null and then Event.Value.List /= null then
         Event.Value.List.all.Cancel (Event.Value);
         Event.Value.List := null;
      end if;
   end Cancel;

   --  -----------------------
   --  Check if the timer is ready to be executed.
   --  -----------------------
   function Is_Scheduled (Event : in Timer_Ref) return Boolean is
   begin
      return Event.Value /= null and then Event.Value.List /= null;
   end Is_Scheduled;

   --  -----------------------
   --  Returns the deadline time for the timer execution.
   --  Returns Time'Last if the timer is not scheduled.
   --  -----------------------
   function Time_Of_Event (Event : in Timer_Ref) return Ada.Real_Time.Time is
   begin
      return (if Event.Value /= null then Event.Value.Deadline else Ada.Real_Time.Time_Last);
   end Time_Of_Event;

   --  -----------------------
   --  Set a timer to be called at the given time.
   --  -----------------------
   procedure Set_Timer (List    : in out Timer_List;
                        Handler : in Timer_Access;
                        Event   : in out Timer_Ref'Class;
                        At_Time : in Ada.Real_Time.Time) is
      Timer : Timer_Node_Access := Event.Value;
   begin
      if Timer = null then
         Event.Value := new Timer_Node;
         Timer := Event.Value;
      end if;
      Timer.Handler := Handler;

      --  Cancel the timer if it is part of another timer manager.
      if Timer.List /= null and Timer.List /= List.Manager'Unchecked_Access then
         Timer.List.Cancel (Timer);
      end if;

      --  Update the timer.
      Timer.List := List.Manager'Unchecked_Access;
      List.Manager.Add (Timer, At_Time);
   end Set_Timer;

   --  -----------------------
   --  Process the timer handlers that have passed the deadline and return the next
   --  deadline.  The <tt>Max_Count</tt> parameter allows to limit the number of timer handlers
   --  that are called by operation.  The default is not limited.
   --  -----------------------
   procedure Process (List      : in out Timer_List;
                      Timeout   : out Ada.Real_Time.Time;
                      Max_Count : in Natural := Natural'Last) is
      Timer : Timer_Ref;
      Now   : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      loop
         List.Manager.Find_Next (Now, Timeout, Timer);
         exit when Timer.Value = null;
         Timer.Value.Handler.Time_Handler (Timer);
         Timer.Finalize;
      end loop;
   end Process;

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

   overriding
   procedure Finalize (Object : in out Timer_Ref) is
      Is_Zero : Boolean;
   begin
      if Object.Value /= null then
         Util.Concurrent.Counters.Decrement (Object.Value.Counter, Is_Zero);
         if Is_Zero then
            Free (Object.Value);
         else
            Object.Value := null;
         end if;
      end if;
   end Finalize;

   protected body Timer_Manager is

      procedure Remove (Timer : in Timer_Node_Access) is
      begin
         if List = Timer then
            List := Timer.Next;
            Timer.Prev := null;
            if List /= null then
               List.Prev := null;
            end if;
         elsif Timer.Prev /= null then
            Timer.Prev.Next := Timer.Next;
            Timer.Next.Prev := Timer.Prev;
         else
            return;
         end if;
         Timer.Next := null;
         Timer.Prev := null;
         Timer.List := null;
      end Remove;

      --  -----------------------
      --  Add a timer.
      --  -----------------------
      procedure Add (Timer    : in Timer_Node_Access;
                     Deadline : in Ada.Real_Time.Time) is
         Current : Timer_Node_Access := List;
         Prev    : Timer_Node_Access;
      begin
         Util.Concurrent.Counters.Increment (Timer.Counter);
         if Timer.List /= null then
            Remove (Timer);
         end if;
         Timer.Deadline := Deadline;
         while Current /= null loop
            if Current.Deadline < Deadline then
               if Prev = null then
                  List := Timer;
               else
                  Prev.Next := Timer;
               end if;
               Timer.Next := Current;
               Current.Prev := Timer;
               return;
            end if;
            Prev := Current;
            Current := Current.Next;
         end loop;
         if Prev = null then
            List := Timer;
            Timer.Prev := null;
         else
            Prev.Next := Timer;
            Timer.Prev := Prev;
         end if;
         Timer.Next := null;
      end Add;

      --  -----------------------
      --  Cancel a timer.
      --  -----------------------
      procedure Cancel (Timer : in out Timer_Node_Access) is
         Is_Zero : Boolean;
      begin
         if Timer.List = null then
            return;
         end if;
         Remove (Timer);
         Util.Concurrent.Counters.Decrement (Timer.Counter, Is_Zero);
         if Is_Zero then
            Free (Timer);
         end if;
      end Cancel;

      --  -----------------------
      --  Find the next timer to be executed before the given time or return the next deadline.
      --  -----------------------
      procedure Find_Next (Before   : in Ada.Real_Time.Time;
                           Deadline : out Ada.Real_Time.Time;
                           Timer    : in out Timer_Ref) is
      begin
         if List = null then
            Deadline := Ada.Real_Time.Time_Last;
         elsif List.Deadline < Before then
            Timer.Value := List;
            List := List.Next;
            if List /= null then
               List.Prev := null;
               Deadline := List.Deadline;
            else
               Deadline := Ada.Real_Time.Time_Last;
            end if;
         else
            Deadline := List.Deadline;
         end if;
      end Find_Next;

   end Timer_Manager;

   overriding
   procedure Finalize (Object : in out Timer_List) is
      Timer    : Timer_Ref;
      Timeout  : Ada.Real_Time.Time;
   begin
      loop
         Object.Manager.Find_Next (Ada.Real_Time.Time_Last, Timeout, Timer);
         exit when Timer.Value = null;
         Timer.Finalize;
      end loop;
   end Finalize;

end Util.Events.Timers;

Update the Process procedure to finalize the timer only after execution of the timer handler


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2018 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.

package body Orka.Containers.Bounded_Vectors is

   function Length (Container : Vector) return Length_Type is
     (Container.Length);

   function Is_Empty (Container : Vector) return Boolean is
     (Length (Container) = 0);

   function Is_Full (Container : Vector) return Boolean is
     (Length (Container) = Container.Capacity);

   procedure Append (Container : in out Vector; Elements : Vector) is
      Start_Index : constant Index_Type := Container.Length + Index_Type'First;
      Stop_Index  : constant Index_Type'Base := Start_Index + Elements.Length - 1;

      procedure Copy_Elements (Elements : Element_Array) is
      begin
         Container.Elements (Start_Index .. Stop_Index) := Elements;
      end Copy_Elements;
   begin
      Elements.Query (Copy_Elements'Access);
      Container.Length := Container.Length + Elements.Length;
   end Append;

   procedure Append (Container : in out Vector; Element : Element_Type) is
      Index : constant Index_Type := Container.Length + Index_Type'First;
   begin
      Container.Length := Container.Length + 1;
      Container.Elements (Index) := Element;
   end Append;

   procedure Remove_Last (Container : in out Vector; Element : out Element_Type) is
      Index : constant Index_Type := Container.Length + Index_Type'First - 1;
   begin
      Element := Container.Elements (Index);
      Container.Elements (Index .. Index) := (others => <>);
      Container.Length := Container.Length - 1;
   end Remove_Last;

   procedure Clear (Container : in out Vector) is
   begin
      Container.Elements := (others => <>);
      Container.Length   := 0;
   end Clear;

   procedure Query
     (Container : Vector;
      Process   : not null access procedure (Elements : Element_Array))
   is
      Last_Index : constant Index_Type'Base := Container.Length + Index_Type'First - 1;
   begin
      Process (Container.Elements (Index_Type'First .. Last_Index));
   end Query;

   procedure Update
     (Container : in out Vector;
      Index     : Index_Type;
      Process   : not null access procedure (Element : in out Element_Type)) is
   begin
      Process (Container.Elements (Index));
   end Update;

   function Element (Container : Vector; Index : Index_Type) return Element_Type is
     (Container.Elements (Index));

   function Element (Container : aliased Vector; Position : Cursor) return Element_Type is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Object /= Container'Access then
         raise Program_Error;
      else
         return Element (Container, Position.Index);
      end if;
   end Element;

   function Constant_Reference
     (Container : aliased Vector;
      Index     : Index_Type) return Constant_Reference_Type is
   begin
      return Constant_Reference_Type'(Value => Container.Elements (Index)'Access);
   end Constant_Reference;

   function Constant_Reference
     (Container : aliased Vector;
      Position  : Cursor) return Constant_Reference_Type is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Object /= Container'Access then
         raise Program_Error;
      else
         return Constant_Reference (Container, Position.Index);
      end if;
   end Constant_Reference;

   function Reference
     (Container : aliased in out Vector;
      Index     : Index_Type) return Reference_Type is
   begin
      return Reference_Type'(Value => Container.Elements (Index)'Access);
   end Reference;

   function Reference
     (Container : aliased in out Vector;
      Position  : Cursor) return Reference_Type is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Object /= Container'Access then
         raise Program_Error;
      else
         return Reference (Container, Position.Index);
      end if;
   end Reference;

   function Iterate (Container : Vector)
     return Vector_Iterator_Interfaces.Reversible_Iterator'Class is
   begin
      return Iterator'(Container => Container'Unchecked_Access);
   end Iterate;

   overriding function First (Object : Iterator) return Cursor is
   begin
      if Object.Container.all.Is_Empty then
         return No_Element;
      else
         return Cursor'(Object => Object.Container, Index => Index_Type'First);
      end if;
   end First;

   overriding function Last  (Object : Iterator) return Cursor is
   begin
      if Object.Container.all.Is_Empty then
         return No_Element;
      else
         return Cursor'(Object => Object.Container,
                        Index  => Object.Container.all.Length);
      end if;
   end Last;

   overriding function Next
     (Object   : Iterator;
      Position : Cursor) return Cursor is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Index = Position.Object.Length + Index_Type'First - 1 then
         return No_Element;
      else
         return Cursor'(Position.Object, Position.Index + 1);
      end if;
   end Next;

   overriding function Previous
     (Object   : Iterator;
      Position : Cursor) return Cursor is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Index = Index_Type'First then
         return No_Element;
      else
         return Cursor'(Position.Object, Position.Index - 1);
      end if;
   end Previous;

end Orka.Containers.Bounded_Vectors;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2018 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.

package body Orka.Containers.Bounded_Vectors is

   function Length (Container : Vector) return Length_Type is
     (Container.Length);

   function Is_Empty (Container : Vector) return Boolean is
     (Length (Container) = 0);

   function Is_Full (Container : Vector) return Boolean is
     (Length (Container) = Container.Capacity);

   procedure Append (Container : in out Vector; Elements : Vector) is
      Start_Index : constant Index_Type := Container.Length + Index_Type'First;
      Stop_Index  : constant Index_Type'Base := Start_Index + Elements.Length - 1;

      procedure Copy_Elements (Elements : Element_Array) is
      begin
         Container.Elements (Start_Index .. Stop_Index) := Elements;
      end Copy_Elements;
   begin
      Elements.Query (Copy_Elements'Access);
      Container.Length := Container.Length + Elements.Length;
   end Append;

   procedure Append (Container : in out Vector; Element : Element_Type) is
      Index : constant Index_Type := Container.Length + Index_Type'First;
   begin
      Container.Length := Container.Length + 1;
      Container.Elements (Index) := Element;
   end Append;

   procedure Remove_Last (Container : in out Vector; Element : out Element_Type) is
      Index : constant Index_Type := Container.Length + Index_Type'First - 1;
   begin
      Element := Container.Elements (Index);
      Container.Elements (Index .. Index) := (others => <>);
      Container.Length := Container.Length - 1;
   end Remove_Last;

   procedure Clear (Container : in out Vector) is
   begin
      Container.Elements := (others => <>);
      Container.Length   := 0;
   end Clear;

   procedure Query
     (Container : Vector;
      Process   : not null access procedure (Elements : Element_Array))
   is
      Last_Index : constant Index_Type'Base := Container.Length + Index_Type'First - 1;
   begin
      Process (Container.Elements (Index_Type'First .. Last_Index));
   end Query;

   procedure Update
     (Container : in out Vector;
      Index     : Index_Type;
      Process   : not null access procedure (Element : in out Element_Type)) is
   begin
      Process (Container.Elements (Index));
   end Update;

   function Element (Container : Vector; Index : Index_Type) return Element_Type is
     (Container.Elements (Index));

   function Element (Container : aliased Vector; Position : Cursor) return Element_Type is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Object.all /= Container then
         raise Program_Error;
      else
         return Element (Container, Position.Index);
      end if;
   end Element;

   function Constant_Reference
     (Container : aliased Vector;
      Index     : Index_Type) return Constant_Reference_Type is
   begin
      return Constant_Reference_Type'(Value => Container.Elements (Index)'Access);
   end Constant_Reference;

   function Constant_Reference
     (Container : aliased Vector;
      Position  : Cursor) return Constant_Reference_Type is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Object.all /= Container then
         raise Program_Error;
      else
         return Constant_Reference (Container, Position.Index);
      end if;
   end Constant_Reference;

   function Reference
     (Container : aliased in out Vector;
      Index     : Index_Type) return Reference_Type is
   begin
      return Reference_Type'(Value => Container.Elements (Index)'Access);
   end Reference;

   function Reference
     (Container : aliased in out Vector;
      Position  : Cursor) return Reference_Type is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Object.all /= Container then
         raise Program_Error;
      else
         return Reference (Container, Position.Index);
      end if;
   end Reference;

   function Iterate (Container : Vector)
     return Vector_Iterator_Interfaces.Reversible_Iterator'Class is
   begin
      return Iterator'(Container => Container'Unchecked_Access);
   end Iterate;

   overriding function First (Object : Iterator) return Cursor is
   begin
      if Object.Container.all.Is_Empty then
         return No_Element;
      else
         return Cursor'(Object => Object.Container, Index => Index_Type'First);
      end if;
   end First;

   overriding function Last  (Object : Iterator) return Cursor is
   begin
      if Object.Container.all.Is_Empty then
         return No_Element;
      else
         return Cursor'(Object => Object.Container,
                        Index  => Object.Container.all.Length);
      end if;
   end Last;

   overriding function Next
     (Object   : Iterator;
      Position : Cursor) return Cursor is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Index = Position.Object.Length + Index_Type'First - 1 then
         return No_Element;
      else
         return Cursor'(Position.Object, Position.Index + 1);
      end if;
   end Next;

   overriding function Previous
     (Object   : Iterator;
      Position : Cursor) return Cursor is
   begin
      if Position = No_Element then
         raise Constraint_Error;
      elsif Position.Index = Index_Type'First then
         return No_Element;
      else
         return Cursor'(Position.Object, Position.Index - 1);
      end if;
   end Previous;

end Orka.Containers.Bounded_Vectors;

Fix compile error with GNAT CE 2021

Fix compile error with GNAT CE 2021

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