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

private with Ada.Containers.Indefinite_Holders;

with GL.Buffers;
with GL.Objects.Framebuffers;
with GL.Objects.Textures;
with GL.Types.Colors;

with Orka.Contexts;
with Orka.Rendering.Buffers;
with Orka.Rendering.Textures;
with Orka.Windows;

package Orka.Rendering.Framebuffers is
   pragma Preelaborate;

   use GL.Types;

   package FB renames GL.Objects.Framebuffers;
   package Textures renames GL.Objects.Textures;

   subtype Color_Attachment_Point is FB.Attachment_Point
     range FB.Color_Attachment_0 .. FB.Color_Attachment_15;

   type Use_Point_Array is array (Rendering.Framebuffers.Color_Attachment_Point) of Boolean;
   --  TODO Use as formal parameter in procedure Invalidate

   type Buffer_Values is record
      Color   : Colors.Color             := (0.0, 0.0, 0.0, 0.0);
      Depth   : GL.Buffers.Depth         := 1.0;
      Stencil : GL.Buffers.Stencil_Index := 0;
   end record;

   type Framebuffer
     (Default : Boolean;
      Width, Height, Samples : Size) is tagged private
   with Type_Invariant => (if Framebuffer.Default then Framebuffer.Samples = 0);

   type Framebuffer_Ptr is not null access Framebuffer;

   function Create_Framebuffer
     (Width, Height, Samples : Size;
      Context : Contexts.Context'Class) return Framebuffer
   with Pre  => Samples > 0 and Context.Enabled (Contexts.Multisample),
        Post => not Create_Framebuffer'Result.Default;

   function Create_Framebuffer (Width, Height : Size) return Framebuffer
     with Post => not Create_Framebuffer'Result.Default;

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

   function Get_Default_Framebuffer
     (Window : Orka.Windows.Window'Class) return Framebuffer
   with Post => Get_Default_Framebuffer'Result.Default;

   function Create_Default_Framebuffer
     (Width, Height : Size) return Framebuffer
   with Post => Create_Default_Framebuffer'Result.Default;

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

   function GL_Framebuffer (Object : Framebuffer) return FB.Framebuffer
     with Inline;

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

   function Image (Object : Framebuffer) return String;
   --  Return a description of the given framebuffer

   procedure Use_Framebuffer (Object : Framebuffer);
   --  Use the framebuffer during rendering
   --
   --  The viewport is adjusted to the size of the framebuffer.

   procedure Set_Default_Values (Object : in out Framebuffer; Values : Buffer_Values);
   --  Set the default values for the color buffers and depth and stencil
   --  buffers

   function Default_Values (Object : Framebuffer) return Buffer_Values;
   --  Return the current default values used when clearing the attached
   --  textures

   procedure Set_Read_Buffer
     (Object : Framebuffer;
      Buffer : GL.Buffers.Color_Buffer_Selector);
   --  Set the buffer to use when blitting to another framebuffer with
   --  procedure Resolve_To

   procedure Set_Draw_Buffers
     (Object  : in out Framebuffer;
      Buffers : GL.Buffers.Color_Buffer_List);
   --  Set the buffers to use when drawing to output variables in a fragment
   --  shader, when calling procedure Clear, or when another framebuffer
   --  blits its read buffer to this framebuffer with procedure Resolve_To

   procedure Clear
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits := (others => True));
   --  Clear the attached textures for which the mask is True using
   --  the default values set with Set_Default_Values
   --
   --  For clearing to be effective, the following conditions must apply:
   --
   --    - Write mask off
   --    - Rasterizer discard disabled
   --    - Scissor test off or scissor rectangle set to the desired region
   --    - Called procedure Set_Draw_Buffers with a list of attachments
   --
   --  If a combined depth/stencil texture has been attached, the depth
   --  and stencil components can be cleared separately, but it may be
   --  faster to clear both components.

   procedure Invalidate
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits);
   --  Invalidate the attached textures for which the mask is True

   procedure Resolve_To
     (Object, Subject : Framebuffer;
      Mask : GL.Buffers.Buffer_Bits := (Color => True, others => False))
   with Pre => Object /= Subject and
                 (Mask.Color or Mask.Depth or Mask.Stencil) and
                 (if Object.Samples > 0 and Subject.Samples > 0 then
                    Object.Samples = Subject.Samples);
   --  Copy one or more buffers, resolving multiple samples and scaling
   --  if necessary, from the source to the destination framebuffer
   --
   --  If a buffer is specified in the mask, then the buffer should exist
   --  in both framebuffers, otherwise the buffer is not copied. Call
   --  Set_Read_Buffer and Set_Draw_Buffers to control which buffer is read
   --  from and which buffers are written to.
   --
   --  Format of color buffers may differ and will be converted (if
   --  supported). Formats of depth and stencil buffers must match.
   --
   --  Note: simultaneously resolving multiple samples and scaling
   --  requires GL_EXT_framebuffer_multisample_blit_scaled.

   procedure Attach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.

   procedure Attach
     (Object  : in out Framebuffer;
      Texture : Textures.Texture;
      Level   : Textures.Mipmap_Level := 0);
   --  Attach the texture to an attachment point based on the internal
   --  format of the texture
   --
   --  Internally calls the procedure Attach above.
   --
   --  If the texture is color renderable, it will always be attached to
   --  Color_Attachment_0. If you need to attach a texture to a different
   --  color attachment point then use the other procedure Attach directly.
   --
   --  If the texture is layered and you want to attach a specific layer,
   --  then you must call the procedure Attach_Layer below instead.

   procedure Attach_Layer
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Layer      : Natural;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  Texture.Layered and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach layer of " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the selected 1D/2D layer of the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.
   --
   --  The texture must be layered (3D, 1D/2D array, cube
   --  map [array], or 2D multisampled array).

   procedure Detach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point)
   with Pre  => not Object.Default,
        Post => not Object.Has_Attachment (Attachment);
   --  Detach any texture currently attached to the given attachment point

   function Has_Attachment
     (Object     : Framebuffer;
      Attachment : FB.Attachment_Point) return Boolean;

   Framebuffer_Incomplete_Error : exception;

private

   package Attachment_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Textures.Texture, "=" => Textures."=");

   package Color_Buffer_List_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => GL.Buffers.Color_Buffer_List, "=" => GL.Buffers."=");

   type Attachment_Array is array (FB.Attachment_Point)
     of Attachment_Holder.Holder;

   type Framebuffer (Default : Boolean; Width, Height, Samples : Size) is tagged record
      GL_Framebuffer : FB.Framebuffer;
      Attachments    : Attachment_Array;
      Defaults       : Buffer_Values;
      Draw_Buffers   : Color_Buffer_List_Holder.Holder;
   end record;

end Orka.Rendering.Framebuffers;

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

private with Ada.Containers.Indefinite_Holders;

with GL.Buffers;
with GL.Objects.Framebuffers;
with GL.Objects.Textures;
with GL.Types.Colors;

with Orka.Contexts;
with Orka.Rendering.Buffers;
with Orka.Rendering.Textures;
with Orka.Windows;

package Orka.Rendering.Framebuffers is
   pragma Preelaborate;

   use GL.Types;

   package FB renames GL.Objects.Framebuffers;
   package Textures renames GL.Objects.Textures;

   subtype Color_Attachment_Point is FB.Attachment_Point
     range FB.Color_Attachment_0 .. FB.Color_Attachment_15;

   type Use_Point_Array is array (Rendering.Framebuffers.Color_Attachment_Point) of Boolean;
   --  TODO Use as formal parameter in procedure Invalidate

   type Buffer_Values is record
      Color   : Colors.Color             := (0.0, 0.0, 0.0, 0.0);
      Depth   : GL.Buffers.Depth         := 1.0;
      Stencil : GL.Buffers.Stencil_Index := 0;
   end record;

   type Framebuffer
     (Default : Boolean;
      Width, Height, Samples : Size) is tagged private
   with Type_Invariant => (if Framebuffer.Default then Framebuffer.Samples = 0);

   type Framebuffer_Ptr is not null access Framebuffer;

   function Create_Framebuffer
     (Width, Height, Samples : Size;
      Context : Contexts.Context'Class) return Framebuffer
   with Pre  => (if Samples > 0 then Context.Enabled (Contexts.Multisample)),
        Post => not Create_Framebuffer'Result.Default;

   function Create_Framebuffer (Width, Height : Size) return Framebuffer
     with Post => not Create_Framebuffer'Result.Default;

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

   function Get_Default_Framebuffer
     (Window : Orka.Windows.Window'Class) return Framebuffer
   with Post => Get_Default_Framebuffer'Result.Default;

   function Create_Default_Framebuffer
     (Width, Height : Size) return Framebuffer
   with Post => Create_Default_Framebuffer'Result.Default;

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

   function GL_Framebuffer (Object : Framebuffer) return FB.Framebuffer
     with Inline;

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

   function Image (Object : Framebuffer) return String;
   --  Return a description of the given framebuffer

   procedure Use_Framebuffer (Object : Framebuffer);
   --  Use the framebuffer during rendering
   --
   --  The viewport is adjusted to the size of the framebuffer.

   procedure Set_Default_Values (Object : in out Framebuffer; Values : Buffer_Values);
   --  Set the default values for the color buffers and depth and stencil
   --  buffers

   function Default_Values (Object : Framebuffer) return Buffer_Values;
   --  Return the current default values used when clearing the attached
   --  textures

   procedure Set_Read_Buffer
     (Object : Framebuffer;
      Buffer : GL.Buffers.Color_Buffer_Selector);
   --  Set the buffer to use when blitting to another framebuffer with
   --  procedure Resolve_To

   procedure Set_Draw_Buffers
     (Object  : in out Framebuffer;
      Buffers : GL.Buffers.Color_Buffer_List);
   --  Set the buffers to use when drawing to output variables in a fragment
   --  shader, when calling procedure Clear, or when another framebuffer
   --  blits its read buffer to this framebuffer with procedure Resolve_To

   procedure Clear
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits := (others => True));
   --  Clear the attached textures for which the mask is True using
   --  the default values set with Set_Default_Values
   --
   --  For clearing to be effective, the following conditions must apply:
   --
   --    - Write mask off
   --    - Rasterizer discard disabled
   --    - Scissor test off or scissor rectangle set to the desired region
   --    - Called procedure Set_Draw_Buffers with a list of attachments
   --
   --  If a combined depth/stencil texture has been attached, the depth
   --  and stencil components can be cleared separately, but it may be
   --  faster to clear both components.

   procedure Invalidate
     (Object : Framebuffer;
      Mask   : GL.Buffers.Buffer_Bits);
   --  Invalidate the attached textures for which the mask is True

   procedure Resolve_To
     (Object, Subject : Framebuffer;
      Mask : GL.Buffers.Buffer_Bits := (Color => True, others => False))
   with Pre => Object /= Subject and
                 (Mask.Color or Mask.Depth or Mask.Stencil) and
                 (if Object.Samples > 0 and Subject.Samples > 0 then
                    Object.Samples = Subject.Samples);
   --  Copy one or more buffers, resolving multiple samples and scaling
   --  if necessary, from the source to the destination framebuffer
   --
   --  If a buffer is specified in the mask, then the buffer should exist
   --  in both framebuffers, otherwise the buffer is not copied. Call
   --  Set_Read_Buffer and Set_Draw_Buffers to control which buffer is read
   --  from and which buffers are written to.
   --
   --  Format of color buffers may differ and will be converted (if
   --  supported). Formats of depth and stencil buffers must match.
   --
   --  Note: simultaneously resolving multiple samples and scaling
   --  requires GL_EXT_framebuffer_multisample_blit_scaled.

   procedure Attach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.

   procedure Attach
     (Object  : in out Framebuffer;
      Texture : Textures.Texture;
      Level   : Textures.Mipmap_Level := 0);
   --  Attach the texture to an attachment point based on the internal
   --  format of the texture
   --
   --  Internally calls the procedure Attach above.
   --
   --  If the texture is color renderable, it will always be attached to
   --  Color_Attachment_0. If you need to attach a texture to a different
   --  color attachment point then use the other procedure Attach directly.
   --
   --  If the texture is layered and you want to attach a specific layer,
   --  then you must call the procedure Attach_Layer below instead.

   procedure Attach_Layer
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point;
      Texture    : Textures.Texture;
      Layer      : Natural;
      Level      : Textures.Mipmap_Level := 0)
   with Pre  => (not Object.Default and Texture.Allocated and
                  Texture.Layered and
                  (if Attachment in Color_Attachment_Point then
                    (Object.Width  = Texture.Width  (Level) and
                     Object.Height = Texture.Height (Level))))
                or else raise Constraint_Error with
                  "Cannot attach layer of " & Rendering.Textures.Image (Texture, Level) &
                  " to " & Object.Image,
        Post => Object.Has_Attachment (Attachment);
   --  Attach the selected 1D/2D layer of the texture to the attachment point
   --
   --  The internal format of the texture must be valid for the given
   --  attachment point.
   --
   --  The texture must be layered (3D, 1D/2D array, cube
   --  map [array], or 2D multisampled array).

   procedure Detach
     (Object     : in out Framebuffer;
      Attachment : FB.Attachment_Point)
   with Pre  => not Object.Default,
        Post => not Object.Has_Attachment (Attachment);
   --  Detach any texture currently attached to the given attachment point

   function Has_Attachment
     (Object     : Framebuffer;
      Attachment : FB.Attachment_Point) return Boolean;

   Framebuffer_Incomplete_Error : exception;

private

   package Attachment_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => Textures.Texture, "=" => Textures."=");

   package Color_Buffer_List_Holder is new Ada.Containers.Indefinite_Holders
     (Element_Type => GL.Buffers.Color_Buffer_List, "=" => GL.Buffers."=");

   type Attachment_Array is array (FB.Attachment_Point)
     of Attachment_Holder.Holder;

   type Framebuffer (Default : Boolean; Width, Height, Samples : Size) is tagged record
      GL_Framebuffer : FB.Framebuffer;
      Attachments    : Attachment_Array;
      Defaults       : Buffer_Values;
      Draw_Buffers   : Color_Buffer_List_Holder.Holder;
   end record;

end Orka.Rendering.Framebuffers;

orka: Fix aspect Pre of function Create_Framebuffer to allow Samples = 0

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


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

with Ada.Unchecked_Deallocation;

with AWS.SMTP.Client;

with Util.Log.Loggers;

package body AWA.Mail.Clients.AWS_SMTP is

   use AWS.SMTP;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Mail.Clients.AWS_SMTP");

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => AWS.SMTP.Recipients,
                                      Name   => Recipients_Access);

   --  Get a printable representation of the email recipients.
   function Image (Recipients : in Recipients_Access) return String;

   --  ------------------------------
   --  Set the <tt>From</tt> part of the message.
   --  ------------------------------
   overriding
   procedure Set_From (Message : in out AWS_Mail_Message;
                       Name    : in String;
                       Address : in String) is
   begin
      Message.From := AWS.SMTP.E_Mail (Name    => Name,
                                       Address => Address);
   end Set_From;

   --  ------------------------------
   --  Add a recipient for the message.
   --  ------------------------------
   overriding
   procedure Add_Recipient (Message : in out AWS_Mail_Message;
                            Kind    : in Recipient_Type;
                            Name    : in String;
                            Address : in String) is
      List : Recipients_Access := Message.To (Kind);
   begin
      if List = null then
         List := new AWS.SMTP.Recipients (1 .. 1);
      else
         declare
            To : constant Recipients_Access := new AWS.SMTP.Recipients (1 .. List'Last + 1);
         begin
            List (List'Range) := List.all;
            Free (List);
            List := To;
         end;
      end if;
      List (List'Last) := AWS.SMTP.E_Mail (Name    => Name,
                                           Address => Address);
      Message.To (Kind) := List;
   end Add_Recipient;

   --  ------------------------------
   --  Set the subject of the message.
   --  ------------------------------
   overriding
   procedure Set_Subject (Message : in out AWS_Mail_Message;
                          Subject : in String) is
   begin
      Message.Subject := To_Unbounded_String (Subject);
   end Set_Subject;

   --  ------------------------------
   --  Set the body of the message.
   --  ------------------------------
   overriding
   procedure Set_Body (Message      : in out AWS_Mail_Message;
                       Content      : in Unbounded_String;
                       Alternative  : in Unbounded_String;
                       Content_Type : in String) is
   begin
      if Length (Alternative) = 0 then
         AWS.Attachments.Add (Message.Attachments, "",
                              AWS.Attachments.Value (To_String (Content)));
      else
         declare
            Parts : AWS.Attachments.Alternatives;
         begin
            AWS.Attachments.Add
              (Parts,
               AWS.Attachments.Value (To_String (Content),
                                      Content_Type => Content_Type));
            AWS.Attachments.Add
              (Parts,
               AWS.Attachments.Value (To_String (Alternative),
                                      Content_Type => "text/plain; charset='UTF-8'"));
            AWS.Attachments.Add
              (Message.Attachments, Parts);
         end;
      end if;
   end Set_Body;

   --  ------------------------------
   --  Add an attachment with the given content.
   --  ------------------------------
   overriding
   procedure Add_Attachment (Message      : in out AWS_Mail_Message;
                             Content      : in Unbounded_String;
                             Content_Id   : in String;
                             Content_Type : in String) is
      Data : constant AWS.Attachments.Content
        := AWS.Attachments.Value (Data => To_String (Content),
                                  Content_Id => Content_Id,
                                  Content_Type => Content_Type);
   begin
      AWS.Attachments.Add (Attachments => Message.Attachments,
                           Name => Content_Id,
                           Data => Data);
   end Add_Attachment;

   --  ------------------------------
   --  Get a printable representation of the email recipients.
   --  ------------------------------
   function Image (Recipients : in Recipients_Access) return String is
      Result : Unbounded_String;
   begin
      if Recipients /= null then
         for I in Recipients'Range loop
            Append (Result, AWS.SMTP.Image (Recipients (I)));
         end loop;
      end if;
      return To_String (Result);
   end Image;

   --  ------------------------------
   --  Send the email message.
   --  ------------------------------
   overriding
   procedure Send (Message : in out AWS_Mail_Message) is
      Result   : AWS.SMTP.Status;
   begin
      if (for all Recipient of Message.To => Recipient = null) then
         return;
      end if;

      if Message.Manager.Enable then
         Log.Info ("Send email from {0} to {1}",
                   AWS.SMTP.Image (Message.From), Image (Message.To (Clients.TO)));

         AWS.SMTP.Client.Send
           (Server  => Message.Manager.Server,
            From    => Message.From,
            To      => (if Message.To (Clients.TO) /= null then Message.To (Clients.TO).all else No_Recipient),
            CC      => (if Message.To (Clients.CC) /= null then Message.To (Clients.CC).all else No_Recipient),
            BCC     => (if Message.To (Clients.BCC) /= null then Message.To (Clients.BCC).all else No_Recipient),
            Subject => To_String (Message.Subject),
            Attachments => Message.Attachments,
            Status  => Result);
         if not AWS.SMTP.Is_Ok (Result) then
            Log.Error ("Cannot send email: {0}",
                       AWS.SMTP.Status_Message (Result));
         end if;

      else
         Log.Info ("Disable send email from {0} to {1}",
                   AWS.SMTP.Image (Message.From), Image (Message.To (Clients.TO)));
      end if;
   end Send;

   --  ------------------------------
   --  Deletes the mail message.
   --  ------------------------------
   overriding
   procedure Finalize (Message : in out AWS_Mail_Message) is
   begin
      Log.Info ("Finalize mail message");
      Free (Message.To (AWA.Mail.Clients.TO));
      Free (Message.To (AWA.Mail.Clients.CC));
      Free (Message.To (AWA.Mail.Clients.BCC));
   end Finalize;

   procedure Initialize (Client : in out AWS_Mail_Manager'Class;
                         Props  : in Util.Properties.Manager'Class) is separate;

   --  ------------------------------
   --  Create a SMTP based mail manager and configure it according to the properties.
   --  ------------------------------
   function Create_Manager (Props : in Util.Properties.Manager'Class) return Mail_Manager_Access is
      Server : constant String := Props.Get (Name => "smtp.host", Default => "localhost");
      Port   : constant String := Props.Get (Name => "smtp.port", Default => "25");
      Enable : constant String := Props.Get (Name => "smtp.enable", Default => "1");
      Result : constant AWS_Mail_Manager_Access := new AWS_Mail_Manager;
   begin
      Log.Info ("Creating SMTP mail manager to server {0}:{1}", Server, Port);

      Result.Port   := Positive'Value (Port);
      Result.Enable := Enable = "1" or Enable = "yes" or Enable = "true";
      Result.Self   := Result;
      Initialize (Result.all, Props);
      return Result.all'Access;
   end Create_Manager;

   --  ------------------------------
   --  Create a new mail message.
   --  ------------------------------
   overriding
   function Create_Message (Manager : in AWS_Mail_Manager) return Mail_Message_Access is
      Result : constant AWS_Mail_Message_Access := new AWS_Mail_Message;
   begin
      Result.Manager := Manager.Self;
      return Result.all'Access;
   end Create_Message;

end AWA.Mail.Clients.AWS_SMTP;

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

with Ada.Unchecked_Deallocation;

with AWS.SMTP.Client;

with Util.Log.Loggers;

package body AWA.Mail.Clients.AWS_SMTP is

   use AWS.SMTP;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Mail.Clients.AWS_SMTP");

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => AWS.SMTP.Recipients,
                                      Name   => Recipients_Access);

   --  Get a printable representation of the email recipients.
   function Image (Recipients : in Recipients_Access) return String;

   --  ------------------------------
   --  Set the <tt>From</tt> part of the message.
   --  ------------------------------
   overriding
   procedure Set_From (Message : in out AWS_Mail_Message;
                       Name    : in String;
                       Address : in String) is
   begin
      Message.From := AWS.SMTP.E_Mail (Name    => Name,
                                       Address => Address);
   end Set_From;

   --  ------------------------------
   --  Add a recipient for the message.
   --  ------------------------------
   overriding
   procedure Add_Recipient (Message : in out AWS_Mail_Message;
                            Kind    : in Recipient_Type;
                            Name    : in String;
                            Address : in String) is
      List : Recipients_Access := Message.To (Kind);
   begin
      if List = null then
         List := new AWS.SMTP.Recipients (1 .. 1);
      else
         declare
            To : constant Recipients_Access := new AWS.SMTP.Recipients (1 .. List'Last + 1);
         begin
            List (List'Range) := List.all;
            Free (List);
            List := To;
         end;
      end if;
      List (List'Last) := AWS.SMTP.E_Mail (Name    => Name,
                                           Address => Address);
      Message.To (Kind) := List;
   end Add_Recipient;

   --  ------------------------------
   --  Set the subject of the message.
   --  ------------------------------
   overriding
   procedure Set_Subject (Message : in out AWS_Mail_Message;
                          Subject : in String) is
   begin
      Message.Subject := To_Unbounded_String (Subject);
   end Set_Subject;

   --  ------------------------------
   --  Set the body of the message.
   --  ------------------------------
   overriding
   procedure Set_Body (Message      : in out AWS_Mail_Message;
                       Content      : in Unbounded_String;
                       Alternative  : in Unbounded_String;
                       Content_Type : in String) is
   begin
      if Length (Alternative) = 0 then
         AWS.Attachments.Add (Message.Attachments, "",
                              AWS.Attachments.Value (To_String (Content)));
      else
         declare
            Parts : AWS.Attachments.Alternatives;
         begin
            AWS.Attachments.Add
              (Parts,
               AWS.Attachments.Value (To_String (Content),
                                      Content_Type => Content_Type));
            AWS.Attachments.Add
              (Parts,
               AWS.Attachments.Value (To_String (Alternative),
                                      Content_Type => "text/plain; charset='UTF-8'"));
            AWS.Attachments.Add
              (Message.Attachments, Parts);
         end;
      end if;
   end Set_Body;

   --  ------------------------------
   --  Add an attachment with the given content.
   --  ------------------------------
   overriding
   procedure Add_Attachment (Message      : in out AWS_Mail_Message;
                             Content      : in Unbounded_String;
                             Content_Id   : in String;
                             Content_Type : in String) is
      Data : constant AWS.Attachments.Content
        := AWS.Attachments.Value (Data => To_String (Content),
                                  Content_Id => Content_Id,
                                  Content_Type => Content_Type);
   begin
      AWS.Attachments.Add (Attachments => Message.Attachments,
                           Name => Content_Id,
                           Data => Data);
   end Add_Attachment;

   overriding
   procedure Add_File_Attachment (Message      : in out AWS_Mail_Message;
                                  Filename     : in String;
                                  Content_Id   : in String;
                                  Content_Type : in String) is
      Data : constant AWS.Attachments.Content
        := AWS.Attachments.File (Filename     => Filename,
                                 Encode       => AWS.Attachments.Base64,
                                 Content_Id   => Content_Id,
                                 Content_Type => Content_Type);
   begin
      AWS.Attachments.Add (Attachments => Message.Attachments,
                           Name => Content_Id,
                           Data => Data);
   end Add_File_Attachment;

   --  ------------------------------
   --  Get a printable representation of the email recipients.
   --  ------------------------------
   function Image (Recipients : in Recipients_Access) return String is
      Result : Unbounded_String;
   begin
      if Recipients /= null then
         for I in Recipients'Range loop
            Append (Result, AWS.SMTP.Image (Recipients (I)));
         end loop;
      end if;
      return To_String (Result);
   end Image;

   --  ------------------------------
   --  Send the email message.
   --  ------------------------------
   overriding
   procedure Send (Message : in out AWS_Mail_Message) is
      function Get_To return AWS.SMTP.Recipients is
         (if Message.To (Clients.TO) /= null then Message.To (Clients.TO).all else No_Recipient);
      function Get_Cc return AWS.SMTP.Recipients is
         (if Message.To (Clients.CC) /= null then Message.To (Clients.CC).all else No_Recipient);
      function Get_Bcc return AWS.SMTP.Recipients is
         (if Message.To (Clients.BCC) /= null then Message.To (Clients.BCC).all else No_Recipient);

      Result   : AWS.SMTP.Status;
   begin
      if (for all Recipient of Message.To => Recipient = null) then
         return;
      end if;

      if Message.Manager.Enable then
         Log.Info ("Send email from {0} to {1}",
                   AWS.SMTP.Image (Message.From), Image (Message.To (Clients.TO)));

         AWS.SMTP.Client.Send
           (Server  => Message.Manager.Server,
            From    => Message.From,
            To      => Get_To,
            CC      => Get_Cc,
            BCC     => Get_Bcc,
            Subject => To_String (Message.Subject),
            Attachments => Message.Attachments,
            Status  => Result);
         if not AWS.SMTP.Is_Ok (Result) then
            Log.Error ("Cannot send email: {0}",
                       AWS.SMTP.Status_Message (Result));
         end if;

      else
         Log.Info ("Disable send email from {0} to {1}",
                   AWS.SMTP.Image (Message.From), Image (Message.To (Clients.TO)));
      end if;
   end Send;

   --  ------------------------------
   --  Deletes the mail message.
   --  ------------------------------
   overriding
   procedure Finalize (Message : in out AWS_Mail_Message) is
   begin
      Log.Info ("Finalize mail message");
      Free (Message.To (AWA.Mail.Clients.TO));
      Free (Message.To (AWA.Mail.Clients.CC));
      Free (Message.To (AWA.Mail.Clients.BCC));
   end Finalize;

   procedure Initialize (Client : in out AWS_Mail_Manager'Class;
                         Props  : in Util.Properties.Manager'Class) is separate;

   --  ------------------------------
   --  Create a SMTP based mail manager and configure it according to the properties.
   --  ------------------------------
   function Create_Manager (Props : in Util.Properties.Manager'Class) return Mail_Manager_Access is
      Server : constant String := Props.Get (Name => "smtp.host", Default => "localhost");
      Port   : constant String := Props.Get (Name => "smtp.port", Default => "25");
      Enable : constant String := Props.Get (Name => "smtp.enable", Default => "1");
      Result : constant AWS_Mail_Manager_Access := new AWS_Mail_Manager;
   begin
      Log.Info ("Creating SMTP mail manager to server {0}:{1}", Server, Port);

      Result.Port   := Positive'Value (Port);
      Result.Enable := Enable = "1" or Enable = "yes" or Enable = "true";
      Result.Self   := Result;
      Initialize (Result.all, Props);
      return Result.all'Access;
   end Create_Manager;

   --  ------------------------------
   --  Create a new mail message.
   --  ------------------------------
   overriding
   function Create_Message (Manager : in AWS_Mail_Manager) return Mail_Message_Access is
      Result : constant AWS_Mail_Message_Access := new AWS_Mail_Message;
   begin
      Result.Manager := Manager.Self;
      return Result.all'Access;
   end Create_Message;

end AWA.Mail.Clients.AWS_SMTP;

Implement Add_File_Attachment to attach a file to a mail


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

--  == OpenID ==
--  The Security.OpenID package implements an authentication framework based
--  on OpenID 2.0.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect 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.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The OpenID manager must be declared and configured.
--
--    Mgr   : Security.OpenID.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the OpenID realm and set the OpenID return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify");
--
--  After this initialization, the OpenID manager can be used in the authentication process.
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.OpenID.End_Point;
--    Assoc    : constant Security.OpenID.Association_Access := new Security.OpenID.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    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.
--
--    Mgr.Verify (Assoc.all, Params, Auth);
--    if Security.OpenID.Get_Status (Auth) = Security.OpenID.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.OpenID.Principal_Access := Security.OpenID.Create_Principal (Auth);
--
private package Security.Auth.OpenID is

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is new Security.Auth.Manager with private;

   --  Initialize the authentication realm.
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  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.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   overriding
   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)
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

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

   --  Verify the authentication result
   overriding
   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);

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

   type Manager is new Security.Auth.Manager with record
      Return_To : Unbounded_String;
      Realm     : Unbounded_String;
   end record;

end Security.Auth.OpenID;

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

--  === OpenID Configuration ==
--  The Open ID provider needs the following configuration parameters:
--
--    openid.realm          The OpenID realm parameter passed in the authentication URL.
--    openid.callback_url   The OpenID return_to parameter.
--
private package Security.Auth.OpenID is

   --  ------------------------------
   --  OpenID Manager
   --  ------------------------------
   --  The Manager provides the core operations for the OpenID process.
   type Manager is new Security.Auth.Manager with private;

   --  Initialize the OpenID authentication realm.  Get the <tt>openid.realm</tt>
   --  and <tt>openid.callback_url</tt> parameters to configure the realm.
   overriding
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  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.
   --  Read the XRDS document from the URI and initialize the OpenID provider end point.
   --  (See OpenID Section 7.3 Discovery)
   overriding
   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)
   overriding
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   overriding
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   overriding
   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);

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

   type Manager is new Security.Auth.Manager with record
      Return_To : Unbounded_String;
      Realm     : Unbounded_String;
   end record;

end Security.Auth.OpenID;

Document the OpenID configuration parameters


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

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

package Security.Policies is

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is
     array (Permissions.Permission_Index range <>) of Controller_Access;

   type Policy_Index is new Positive;

   type Policy_Context is limited interface;
   type Policy_Context_Access is access all Policy_Context'Class;

   type Policy_Context_Array is
     array (Policy_Index range <>) of Policy_Context_Access;
   type Policy_Context_Array_Access is access Policy_Context_Array;

   --  ------------------------------
   --  Security policy
   --  ------------------------------
   type Policy is new Ada.Finalization.Limited_Controlled with private;
   type Policy_Access is access all Policy'Class;

   --  Get the policy name.
   function Get_Name (From : in Policy) return String;

   --  Get the policy index.
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index;
   pragma Inline (Get_Policy_Index);

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Pol     : in out Policy;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Into    : in out Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access);

   Invalid_Name : exception;

   Policy_Error : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Checks whether the permission defined by the Permission controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  Create the policy contexts to be associated with the security context.
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access;

   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access;
   pragma Inline_Always (Get_Controller);

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

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

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Access_Array is array (Policy_Index range <>) of Policy_Access;

   type Policy is new Ada.Finalization.Limited_Controlled with record
      Manager : Policy_Manager_Access;
      Index   : Policy_Index;
   end record;

   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with record
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;

      --  The security policies.
      Policies     : Policy_Access_Array (1 .. Max_Policies);
   end record;

end Security.Policies;

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

with Ada.Finalization;

with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with Security.Permissions;
limited with Security.Controllers;
limited with Security.Contexts;

package Security.Policies is

   type Security_Context_Access is access all Contexts.Security_Context'Class;

   type Controller_Access is access all Security.Controllers.Controller'Class;

   type Controller_Access_Array is
     array (Permissions.Permission_Index range <>) of Controller_Access;

   type Policy_Index is new Positive;

   type Policy_Context is limited interface;
   type Policy_Context_Access is access all Policy_Context'Class;

   type Policy_Context_Array is
     array (Policy_Index range <>) of Policy_Context_Access;
   type Policy_Context_Array_Access is access Policy_Context_Array;

   --  ------------------------------
   --  Security policy
   --  ------------------------------
   type Policy is new Ada.Finalization.Limited_Controlled with private;
   type Policy_Access is access all Policy'Class;

   --  Get the policy name.
   function Get_Name (From : in Policy) return String;

   --  Get the policy index.
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index;
   pragma Inline (Get_Policy_Index);

   --  Prepare the XML parser to read the policy configuration.
   procedure Prepare_Config (Pol     : in out Policy;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   procedure Finish_Config (Into    : in out Policy;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is null;

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy;
                             Name       : in String;
                             Permission : in Controller_Access);

   Invalid_Name : exception;

   Policy_Error : exception;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------
   --  The Permission_Manager verifies through some policy that a permission
   --  is granted to a user.
   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with private;
   type Policy_Manager_Access is access all Policy_Manager'Class;

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access;

   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access);

   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access);

   --  Checks whether the permission defined by the Permission controller data is granted
   --  by the security context passed in Context.
   --  Returns true if such permission is granted.
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  Create the policy contexts to be associated with the security context.
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access;

   --  Read the policy file
   procedure Read_Policy (Manager : in out Policy_Manager;
                          File    : in String);

   --  Initialize the permission manager.
   overriding
   procedure Initialize (Manager : in out Policy_Manager);

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager);

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

   --  Setup the XML parser to read the policy description.  For example:
   --
   --  <policy id='1'>
   --     <permission>create-workspace</permission>
   --     <permission>admin</permission>
   --     <url-pattern>/workspace/create</url-pattern>
   --     <url-pattern>/workspace/setup/*</url-pattern>
   --  </policy>
   --
   --  This policy gives access to the URL that match one of the URL pattern if the
   --  security context has the permission create-workspace or admin.
   generic
      Reader  : in out Util.Serialize.IO.XML.Parser;
      Manager : in Policy_Manager_Access;
   package Reader_Config is
      Config : aliased Policy_Config;
   end Reader_Config;

private

   subtype Permission_Index is Permissions.Permission_Index;

   type Permission_Index_Array is array (Positive range <>) of Permissions.Permission_Index;

   type Controller_Access_Array_Access is access all Controller_Access_Array;

   type Policy_Access_Array is array (Policy_Index range <>) of Policy_Access;

   type Policy is new Ada.Finalization.Limited_Controlled with record
      Manager : Policy_Manager_Access;
      Index   : Policy_Index;
   end record;

   type Policy_Manager (Max_Policies : Policy_Index) is
     new Ada.Finalization.Limited_Controlled with record
      Permissions  : Controller_Access_Array_Access;
      Last_Index   : Permission_Index := Permission_Index'First;

      --  The security policies.
      Policies     : Policy_Access_Array (1 .. Max_Policies);
   end record;

end Security.Policies;

Remove the Get_Controller function

Remove the Get_Controller function


-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  Copyright (C) 2013, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Serialize.IO.JSON;
with Util.Stacks;
with Util.Log;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is abstract limited new Util.Serialize.IO.Reader with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class);

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class);

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is
   begin
      Handler.Start_Object (Name, Logger);
--      Util.Serialize.IO.JSON.Parser (Handler).Start_Array (Name);
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is
   begin
      Parser'Class (Handler).Set_Member ("length", Util.Beans.Objects.To_Object (Count), Logger);
      Handler.Finish_Object (Name, Logger);
--      Util.Serialize.IO.JSON.Parser (Handler).Finish_Array (Name, Count);
   end Finish_Array;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
      R : Util.Serialize.IO.JSON.Parser;
   begin
      P.Separator        := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Manager          := Manager'Access;
      R.Parse_String (Content, P);
      if R.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
      R : Util.Serialize.IO.JSON.Parser;
   begin
      P.Manager   := Manager'Access;
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      R.Parse (Path, P);
      if R.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Read_JSON;

end Util.Properties.JSON;

-----------------------------------------------------------------------
--  util-properties-json -- read json files into properties
--  Copyright (C) 2013, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Serialize.IO.JSON;
with Util.Stacks;
with Util.Log;
with Util.Beans.Objects;
package body Util.Properties.JSON is

   type Natural_Access is access all Natural;

   package Length_Stack is new Util.Stacks (Element_Type        => Natural,
                                            Element_Type_Access => Natural_Access);

   type Parser is abstract limited new Util.Serialize.IO.Reader with record
      Base_Name        : Ada.Strings.Unbounded.Unbounded_String;
      Lengths          : Length_Stack.Stack;
      Separator        : Ada.Strings.Unbounded.Unbounded_String;
      Separator_Length : Natural;
   end record;

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class);

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class);

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class);

   --  -----------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  -----------------------
   overriding
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String;
                           Logger  : in out Util.Log.Logging'Class) is
      pragma Unreferenced (Logger);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Name);
         Ada.Strings.Unbounded.Append (Handler.Base_Name, Handler.Separator);
         Length_Stack.Push (Handler.Lengths);
         Length_Stack.Current (Handler.Lengths).all := Name'Length + Handler.Separator_Length;
      end if;
   end Start_Object;

   --  -----------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  -----------------------
   overriding
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String;
                            Logger  : in out Util.Log.Logging'Class) is
      pragma Unreferenced (Logger);
      Len : constant Natural := Ada.Strings.Unbounded.Length (Handler.Base_Name);
   begin
      if Name'Length > 0 then
         Ada.Strings.Unbounded.Delete (Handler.Base_Name,
                                       Len - Name'Length - Handler.Separator_Length + 1, Len);
      end if;
   end Finish_Object;

   overriding
   procedure Start_Array (Handler : in out Parser;
                          Name    : in String;
                          Logger  : in out Util.Log.Logging'Class) is
   begin
      Handler.Start_Object (Name, Logger);
--      Util.Serialize.IO.JSON.Parser (Handler).Start_Array (Name);
   end Start_Array;

   overriding
   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String;
                           Count   : in Natural;
                           Logger  : in out Util.Log.Logging'Class) is
   begin
      Parser'Class (Handler).Set_Member ("length", Util.Beans.Objects.To_Object (Count), Logger);
      Handler.Finish_Object (Name, Logger);
--      Util.Serialize.IO.JSON.Parser (Handler).Finish_Array (Name, Count);
   end Finish_Array;

   --  -----------------------
   --  Parse the JSON content and put the flattened content in the property manager.
   --  -----------------------
   procedure Parse_JSON (Manager : in out Util.Properties.Manager'Class;
                         Content : in String;
                         Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Logger, Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
      R : Util.Serialize.IO.JSON.Parser;
   begin
      P.Separator        := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      P.Manager          := Manager'Access;
      R.Parse_String (Content, P);
      if R.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Parse_JSON;

   --  -----------------------
   --  Read the JSON file into the property manager.
   --  The JSON content is flatten into Flatten the JSON content and add the properties.
   --  -----------------------
   procedure Read_JSON (Manager : in out Util.Properties.Manager'Class;
                        Path    : in String;
                        Flatten_Separator : in String := ".") is

      type Local_Parser is new Parser with record
         Manager : access Util.Properties.Manager'Class;
      end record;

      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False);

      --  -----------------------
      --  Set the name/value pair on the current object.  For each active mapping,
      --  find whether a rule matches our name and execute it.
      --  -----------------------
      overriding
      procedure Set_Member (Handler   : in out Local_Parser;
                            Name      : in String;
                            Value     : in Util.Beans.Objects.Object;
                            Logger    : in out Util.Log.Logging'Class;
                            Attribute : in Boolean := False) is
         pragma Unreferenced (Logger, Attribute);
      begin
         Handler.Manager.Set (Ada.Strings.Unbounded.To_String (Handler.Base_Name) & Name,
                              Util.Beans.Objects.To_String (Value));
      end Set_Member;

      P : Local_Parser;
      R : Util.Serialize.IO.JSON.Parser;
   begin
      P.Manager   := Manager'Access;
      P.Separator := Ada.Strings.Unbounded.To_Unbounded_String (Flatten_Separator);
      P.Separator_Length := Flatten_Separator'Length;
      R.Parse (Path, P);
      if R.Has_Error then
         raise Util.Serialize.IO.Parse_Error;
      end if;
   end Read_JSON;

end Util.Properties.JSON;

Fix compilation warning unused Logger parameter