-----------------------------------------------------------------------
--  components-core-views -- ASF View Components
--  Copyright (C) 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 Util.Beans.Objects;
with Util.Locales;

with ASF.Events.Faces;
with ASF.Lifecycles;
with ASF.Components.Html.Forms;
with ASF.Components.Core;
with ASF.Views.Nodes;
private with Ada.Containers.Vectors;
package ASF.Components.Core.Views is

   --  Name of the facet that holds the metadata information
   --  (we use the same name as JSF 2 specification).
   METADATA_FACET_NAME : constant String := "javax_faces_metadata";

   type UIViewMetaData;
   type UIViewMetaData_Access is access all UIViewMetaData'Class;

   --  ------------------------------
   --  View component
   --  ------------------------------
   type UIView is new Core.UIComponentBase with private;
   type UIView_Access is access all UIView'Class;

   --  Get the content type returned by the view.
   function Get_Content_Type (UI      : in UIView;
                              Context : in Faces_Context'Class) return String;

   --  Set the content type returned by the view.
   procedure Set_Content_Type (UI     : in out UIView;
                               Value  : in String);

   --  Get the locale to be used when rendering messages in the view.
   --  If a locale was set explicitly, return it.
   --  If the view component defines a locale attribute, evaluate and return its value.
   --  If the locale is empty, calculate the locale by using the request context and the view
   --  handler.
   function Get_Locale (UI      : in UIView;
                        Context : in Faces_Context'Class) return Util.Locales.Locale;

   --  Set the locale to be used when rendering messages in the view.
   procedure Set_Locale (UI     : in out UIView;
                         Locale : in Util.Locales.Locale);

   --  Encode the begining of the view.  Set the response content type.
   overriding
   procedure Encode_Begin (UI      : in UIView;
                           Context : in out Faces_Context'Class);

   --  Encode the end of the view.
   overriding
   procedure Encode_End (UI      : in UIView;
                         Context : in out Faces_Context'Class);

   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   overriding
   procedure Process_Decodes (UI      : in out UIView;
                              Context : in out Faces_Context'Class);

   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   overriding
   procedure Process_Validators (UI      : in out UIView;
                                 Context : in out Faces_Context'Class);

   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   overriding
   procedure Process_Updates (UI      : in out UIView;
                              Context : in out Faces_Context'Class);

   --  Broadcast any events that have been queued for the Invoke Application
   --  phase of the request processing lifecycle and to clear out any events
   --  for later phases if the event processing for this phase caused
   --  renderResponse or responseComplete to be called.
   procedure Process_Application (UI      : in out UIView;
                                  Context : in out Faces_Context'Class);

   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   procedure Queue_Event (UI    : in out UIView;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class);

   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   procedure Broadcast (UI      : in out UIView;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class);

   --  Clear the events that were queued.
   procedure Clear_Events (UI : in out UIView);

   --  Set the component tree that must be rendered before this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   procedure Set_Before_View (UI   : in out UIView'Class;
                              Tree : in Base.UIComponent_Access);

   --  Set the component tree that must be rendered after this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   procedure Set_After_View (UI   : in out UIView'Class;
                             Tree : in Base.UIComponent_Access);

   --  Set the metadata facet on the UIView component.
   procedure Set_Metadata (UI    : in out UIView;
                           Meta  : in UIViewMetaData_Access;
                           Tag   : access ASF.Views.Nodes.Tag_Node'Class);

   --  Finalize the object.
   overriding
   procedure Finalize (UI : in out UIView);

   --  ------------------------------
   --  View Parameter Component
   --  ------------------------------
   --  The UIViewParameter component represents a request parameter that must be mapped
   --  to a backed bean object.  This component does not participate in the rendering.
   type UIViewParameter is new Html.Forms.UIInput with private;
   type UIViewParameter_Access is access all UIViewParameter'Class;

   --  Get the input parameter from the submitted context.  This operation is called by
   --  <tt>Process_Decodes</tt> to retrieve the request parameter associated with the component.
   overriding
   function Get_Parameter (UI      : in UIViewParameter;
                           Context : in Faces_Context'Class) return String;

   --  ------------------------------
   --  View Action Component
   --  ------------------------------
   --  The UIViewAction component implements the view action tag defined by Jave Server
   --  Faces 2.2.  This action defined by that tag will be called
   type UIViewAction is new Html.Forms.UICommand with private;
   type UIViewAction_Access is access all UIViewAction'Class;

   --  Decode the request and prepare for the execution for the view action.
   overriding
   procedure Process_Decodes (UI      : in out UIViewAction;
                              Context : in out Faces_Context'Class);

   --  ------------------------------
   --  View Metadata Component
   --  ------------------------------
   --  The UIViewMetaData component defines the view meta data components.
   --  These components defines how to handle some request parameters for a GET request
   --  as well as some actions that must be made upon reception of a request.
   --
   --  From ASF lifecycle management, if the request is a GET, this component is used
   --  as the root of the component tree.  The APPLY_REQUESTS .. INVOKE_APPLICATION actions
   --  are called on that component tree.  It is also used for the RENDER_RESPONSE, and
   --  we have to propagate the rendering on the real view root.  Therefore, the Encode_XXX
   --  operations are overriden to propagate on the real root.
   type UIViewMetaData is new UIView with private;

   --  Start encoding the UIComponent.
   overriding
   procedure Encode_Begin (UI      : in UIViewMetaData;
                           Context : in out Faces_Context'Class);

   --  Encode the children of this component.
   overriding
   procedure Encode_Children (UI      : in UIViewMetaData;
                              Context : in out Faces_Context'Class);

   --  Finish encoding the component.
   overriding
   procedure Encode_End (UI      : in UIViewMetaData;
                         Context : in out Faces_Context'Class);

   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   overriding
   procedure Queue_Event (UI    : in out UIViewMetaData;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class);

   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   overriding
   procedure Broadcast (UI      : in out UIViewMetaData;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class);

   --  Clear the events that were queued.
   overriding
   procedure Clear_Events (UI : in out UIViewMetaData);

   --  Get the root component.
   function Get_Root (UI      : in UIViewMetaData) return Base.UIComponent_Access;

private

   use ASF.Lifecycles;

   type Faces_Event_Access is access all ASF.Events.Faces.Faces_Event'Class;

   package Event_Vectors is new Ada.Containers.Vectors (Index_Type   => Natural,
                                                        Element_Type => Faces_Event_Access);

   type Event_Queues is array (Phase_Type) of Event_Vectors.Vector;

   type UIView is new Core.UIComponentBase with record
      Content_Type : Util.Beans.Objects.Object;
      Phase_Events : Event_Queues;
      Meta         : UIViewMetaData_Access := null;
      Locale       : Util.Locales.Locale := Util.Locales.NULL_LOCALE;
      Left_Tree    : Base.UIComponent_Access := null;
      Right_Tree   : Base.UIComponent_Access := null;
   end record;

   type UIViewParameter is new Html.Forms.UIInput with record
      Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type UIViewAction is new Html.Forms.UICommand with null record;

   type UIViewMetaData is new UIView with record
      Root : UIView_Access := null;
   end record;

end ASF.Components.Core.Views;

-----------------------------------------------------------------------
--  components-core-views -- ASF View Components
--  Copyright (C) 2009, 2010, 2011, 2012, 2017, 2021 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.Beans.Objects;
with Util.Locales;

with ASF.Events.Faces;
with ASF.Lifecycles;
with ASF.Components.Html.Forms;
with ASF.Components.Core;
with ASF.Views.Nodes;
private with Ada.Containers.Vectors;
package ASF.Components.Core.Views is

   --  Name of the facet that holds the metadata information
   --  (we use the same name as JSF 2 specification).
   METADATA_FACET_NAME : constant String := "javax_faces_metadata";

   type UIViewMetaData is tagged;
   type UIViewMetaData_Access is access all UIViewMetaData'Class;

   --  ------------------------------
   --  View component
   --  ------------------------------
   type UIView is new Core.UIComponentBase with private;
   type UIView_Access is access all UIView'Class;

   --  Get the content type returned by the view.
   function Get_Content_Type (UI      : in UIView;
                              Context : in Faces_Context'Class) return String;

   --  Set the content type returned by the view.
   procedure Set_Content_Type (UI     : in out UIView;
                               Value  : in String);

   --  Get the locale to be used when rendering messages in the view.
   --  If a locale was set explicitly, return it.
   --  If the view component defines a locale attribute, evaluate and return its value.
   --  If the locale is empty, calculate the locale by using the request context and the view
   --  handler.
   function Get_Locale (UI      : in UIView;
                        Context : in Faces_Context'Class) return Util.Locales.Locale;

   --  Set the locale to be used when rendering messages in the view.
   procedure Set_Locale (UI     : in out UIView;
                         Locale : in Util.Locales.Locale);

   --  Encode the begining of the view.  Set the response content type.
   overriding
   procedure Encode_Begin (UI      : in UIView;
                           Context : in out Faces_Context'Class);

   --  Encode the end of the view.
   overriding
   procedure Encode_End (UI      : in UIView;
                         Context : in out Faces_Context'Class);

   --  Decode any new state of the specified component from the request contained
   --  in the specified context and store that state on the component.
   --
   --  During decoding, events may be enqueued for later processing
   --  (by event listeners that have registered an interest), by calling
   --  the Queue_Event on the associated component.
   overriding
   procedure Process_Decodes (UI      : in out UIView;
                              Context : in out Faces_Context'Class);

   --  Perform the component tree processing required by the Process Validations
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows:
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Validators of all facets and children.
   --

   overriding
   procedure Process_Validators (UI      : in out UIView;
                                 Context : in out Faces_Context'Class);

   --  Perform the component tree processing required by the Update Model Values
   --  phase of the request processing lifecycle for all facets of this component,
   --  all children of this component, and this component itself, as follows.
   --

   --
If this component rendered property is false, skip further processing.
   --
Call the Process_Updates/b> of all facets and children.
   --

   overriding
   procedure Process_Updates (UI      : in out UIView;
                              Context : in out Faces_Context'Class);

   --  Broadcast any events that have been queued for the Invoke Application
   --  phase of the request processing lifecycle and to clear out any events
   --  for later phases if the event processing for this phase caused
   --  renderResponse or responseComplete to be called.
   procedure Process_Application (UI      : in out UIView;
                                  Context : in out Faces_Context'Class);

   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   procedure Queue_Event (UI    : in out UIView;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class);

   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   procedure Broadcast (UI      : in out UIView;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class);

   --  Clear the events that were queued.
   procedure Clear_Events (UI : in out UIView);

   --  Set the component tree that must be rendered before this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   procedure Set_Before_View (UI   : in out UIView'Class;
                              Tree : in Base.UIComponent_Access);

   --  Set the component tree that must be rendered after this view.
   --  This is an internal method used by Steal_Root_Component exclusively.
   procedure Set_After_View (UI   : in out UIView'Class;
                             Tree : in Base.UIComponent_Access);

   --  Set the metadata facet on the UIView component.
   procedure Set_Metadata (UI    : in out UIView;
                           Meta  : in UIViewMetaData_Access;
                           Tag   : access ASF.Views.Nodes.Tag_Node'Class);

   --  Finalize the object.
   overriding
   procedure Finalize (UI : in out UIView);

   --  ------------------------------
   --  View Parameter Component
   --  ------------------------------
   --  The UIViewParameter component represents a request parameter that must be mapped
   --  to a backed bean object.  This component does not participate in the rendering.
   type UIViewParameter is new Html.Forms.UIInput with private;
   type UIViewParameter_Access is access all UIViewParameter'Class;

   --  Get the input parameter from the submitted context.  This operation is called by
   --  <tt>Process_Decodes</tt> to retrieve the request parameter associated with the component.
   overriding
   function Get_Parameter (UI      : in UIViewParameter;
                           Context : in Faces_Context'Class) return String;

   --  ------------------------------
   --  View Action Component
   --  ------------------------------
   --  The UIViewAction component implements the view action tag defined by Jave Server
   --  Faces 2.2.  This action defined by that tag will be called
   type UIViewAction is new Html.Forms.UICommand with private;
   type UIViewAction_Access is access all UIViewAction'Class;

   --  Decode the request and prepare for the execution for the view action.
   overriding
   procedure Process_Decodes (UI      : in out UIViewAction;
                              Context : in out Faces_Context'Class);

   --  ------------------------------
   --  View Metadata Component
   --  ------------------------------
   --  The UIViewMetaData component defines the view meta data components.
   --  These components defines how to handle some request parameters for a GET request
   --  as well as some actions that must be made upon reception of a request.
   --
   --  From ASF lifecycle management, if the request is a GET, this component is used
   --  as the root of the component tree.  The APPLY_REQUESTS .. INVOKE_APPLICATION actions
   --  are called on that component tree.  It is also used for the RENDER_RESPONSE, and
   --  we have to propagate the rendering on the real view root.  Therefore, the Encode_XXX
   --  operations are overriden to propagate on the real root.
   type UIViewMetaData is new UIView with private;

   --  Start encoding the UIComponent.
   overriding
   procedure Encode_Begin (UI      : in UIViewMetaData;
                           Context : in out Faces_Context'Class);

   --  Encode the children of this component.
   overriding
   procedure Encode_Children (UI      : in UIViewMetaData;
                              Context : in out Faces_Context'Class);

   --  Finish encoding the component.
   overriding
   procedure Encode_End (UI      : in UIViewMetaData;
                         Context : in out Faces_Context'Class);

   --  Queue an event for broadcast at the end of the current request
   --  processing lifecycle phase.  The event object
   --  will be freed after being dispatched.
   overriding
   procedure Queue_Event (UI    : in out UIViewMetaData;
                          Event : not null access ASF.Events.Faces.Faces_Event'Class);

   --  Broadcast the events after the specified lifecycle phase.
   --  Events that were queued will be freed.
   overriding
   procedure Broadcast (UI      : in out UIViewMetaData;
                        Phase   : in ASF.Lifecycles.Phase_Type;
                        Context : in out Faces_Context'Class);

   --  Clear the events that were queued.
   overriding
   procedure Clear_Events (UI : in out UIViewMetaData);

   --  Get the root component.
   function Get_Root (UI      : in UIViewMetaData) return Base.UIComponent_Access;

private

   use ASF.Lifecycles;

   type Faces_Event_Access is access all ASF.Events.Faces.Faces_Event'Class;

   package Event_Vectors is new Ada.Containers.Vectors (Index_Type   => Natural,
                                                        Element_Type => Faces_Event_Access);

   type Event_Queues is array (Phase_Type) of Event_Vectors.Vector;

   type UIView is new Core.UIComponentBase with record
      Content_Type : Util.Beans.Objects.Object;
      Phase_Events : Event_Queues;
      Meta         : UIViewMetaData_Access := null;
      Locale       : Util.Locales.Locale := Util.Locales.NULL_LOCALE;
      Left_Tree    : Base.UIComponent_Access := null;
      Right_Tree   : Base.UIComponent_Access := null;
   end record;

   type UIViewParameter is new Html.Forms.UIInput with record
      Name : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type UIViewAction is new Html.Forms.UICommand with null record;

   type UIViewMetaData is new UIView with record
      Root : UIView_Access := null;
   end record;

end ASF.Components.Core.Views;

Fix compilation warning with GNAT 2021

Fix compilation warning with GNAT 2021


-----------------------------------------------------------------------
--  awa-permissions -- Permissions module
--  Copyright (C) 2011, 2012, 2013, 2014, 2016, 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.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with ADO.Schemas.Entities;
with ADO.Sessions.Entities;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Permissions.Controllers;
package body AWA.Permissions is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Permissions");

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index) is
   begin
      if not (Security.Contexts.Has_Permission (Permission)) then
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Identifier) is
      use type Security.Contexts.Security_Context_Access;

      Context : constant Security.Contexts.Security_Context_Access := Security.Contexts.Current;
      Perm    : Entity_Permission (Permission);
   begin
      if Context = null then
         Log.Debug ("Permission is refused because there is no security context");
         raise NO_PERMISSION;
      end if;
      Perm.Entity := Entity;
      if not Context.Has_Permission (Perm) then
         Log.Debug ("Permission is refused by the security controller");
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Objects.Object_Ref'Class) is
   begin
      if Entity.Is_Null then
         Log.Debug ("Permission is refused because the entity is null.");
         raise NO_PERMISSION;
      end if;
      Check (Permission, ADO.Objects.Get_Value (Entity.Get_Key));
   end Check;

   type Config_Fields is (FIELD_NAME, FIELD_ENTITY_TYPE, FIELD_ENTITY_PERMISSION, FIELD_SQL);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <entity-type>, <sql> and
   --  <entity-permission> XML entities are found.  Create the new permission when the complete
   --  permission definition has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use AWA.Permissions.Controllers;
      use type ADO.Entity_Type;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_SQL =>
            Into.SQL := Value;

         when FIELD_ENTITY_TYPE =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Into.Count = MAX_ENTITY_TYPES then
                  raise Util.Serialize.Mappers.Field_Error with "Too many entity types.";
               end if;
               Into.Count := Into.Count + 1;
               Into.Entities (Into.Count)
                 := ADO.Sessions.Entities.Find_Entity_Type (Into.Session, Name);

            exception
               when ADO.Schemas.Entities.No_Entity_Type =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Name;
            end;

         when FIELD_ENTITY_PERMISSION =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               if Into.Count = 0 then
                  raise Util.Serialize.Mappers.Field_Error
                  with "Permission '" & Name & "' ignored: missing entity type";
               end if;
               declare
                  SQL  : constant String := Util.Beans.Objects.To_String (Into.SQL);
                  Perm : constant Entity_Controller_Access
                    := new Entity_Controller '(Len      => SQL'Length,
                                               SQL      => SQL,
                                               Entities => Into.Entities);
               begin
                  Into.Manager.Add_Permission (Name, Perm.all'Access);
                  Into.Count := 0;
                  Into.Entities := (others => ADO.NO_ENTITY_TYPE);
               end;
            end;

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the entity-permission description.  For example:
   --
   --  <entity-permission>
   --     <name>create-workspace</name>
   --     <entity-type>WORKSPACE</entity-type>
   --     <sql>select acl.id from acl where ...</sql>
   --  </entity-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  SQL statement returns a non empty list.
   --  ------------------------------

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

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out Entity_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : constant Controller_Config_Access := Policy.Config'Unchecked_Access;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config.Session := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("entity-permission", FIELD_ENTITY_PERMISSION);
   Mapper.Add_Mapping ("entity-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("entity-permission/entity-type", FIELD_ENTITY_TYPE);
   Mapper.Add_Mapping ("entity-permission/sql", FIELD_SQL);
end AWA.Permissions;

-----------------------------------------------------------------------
--  awa-permissions -- Permissions module
--  Copyright (C) 2011, 2012, 2013, 2014, 2016, 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.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with ADO.Schemas.Entities;
with ADO.Sessions.Entities;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Permissions.Controllers;
package body AWA.Permissions is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Permissions");

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index) is
   begin
      if not (Security.Contexts.Has_Permission (Permission)) then
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Identifier) is
      use type Security.Contexts.Security_Context_Access;

      Context : constant Security.Contexts.Security_Context_Access := Security.Contexts.Current;
      Perm    : Entity_Permission (Permission);
   begin
      if Context = null then
         Log.Debug ("Permission is refused because there is no security context");
         raise NO_PERMISSION;
      end if;
      Perm.Entity := Entity;
      if not Context.Has_Permission (Perm) then
         Log.Debug ("Permission is refused by the security controller");
         raise NO_PERMISSION;
      end if;
   end Check;

   --  ------------------------------
   --  Verify that the permission represented by Permission is granted to access the
   --  database entity represented by Entity.
   --  ------------------------------
   procedure Check (Permission : in Security.Permissions.Permission_Index;
                    Entity     : in ADO.Objects.Object_Ref'Class) is
   begin
      if Entity.Is_Null then
         Log.Debug ("Permission is refused because the entity is null.");
         raise NO_PERMISSION;
      end if;
      Check (Permission, ADO.Objects.Get_Value (Entity.Get_Key));
   end Check;

   type Config_Fields is (FIELD_NAME, FIELD_ENTITY_TYPE, FIELD_ENTITY_PERMISSION, FIELD_SQL,
                          FIELD_GRANT);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <entity-type>, <sql> and
   --  <entity-permission> XML entities are found.  Create the new permission when the complete
   --  permission definition has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use AWA.Permissions.Controllers;
      use type ADO.Entity_Type;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_SQL =>
            Into.SQL := Value;

         when FIELD_GRANT =>
            Into.Grant := Value;

         when FIELD_ENTITY_TYPE =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
            begin
               if Into.Count = MAX_ENTITY_TYPES then
                  raise Util.Serialize.Mappers.Field_Error with "Too many entity types.";
               end if;
               Into.Count := Into.Count + 1;
               Into.Entities (Into.Count)
                 := ADO.Sessions.Entities.Find_Entity_Type (Into.Session, Name);

            exception
               when ADO.Schemas.Entities.No_Entity_Type =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid entity type: " & Name;
            end;

         when FIELD_ENTITY_PERMISSION =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
            begin
               if Into.Count = 0 then
                  raise Util.Serialize.Mappers.Field_Error
                  with "Permission '" & Name & "' ignored: missing entity type";
               end if;
               declare
                  SQL  : constant String := Util.Beans.Objects.To_String (Into.SQL);
                  Perm : constant Entity_Controller_Access
                    := new Entity_Controller '(Len      => SQL'Length,
                                               SQL      => SQL,
                                               Entities => Into.Entities);
               begin
                  Into.Manager.Add_Permission (Name, Perm.all'Access);
                  Into.Count := 0;
                  Into.Entities := (others => ADO.NO_ENTITY_TYPE);
               end;
            end;

      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Perm_Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the entity-permission description.  For example:
   --
   --  <entity-permission>
   --     <name>create-workspace</name>
   --     <entity-type>WORKSPACE</entity-type>
   --     <sql>select acl.id from acl where ...</sql>
   --  </entity-permission>
   --
   --  This defines a permission create-workspace that will be granted if the
   --  SQL statement returns a non empty list.
   --  ------------------------------

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

   --  ------------------------------
   --  Setup the XML parser to read the policy description.
   --  ------------------------------
   overriding
   procedure Prepare_Config (Policy : in out Entity_Policy;
                             Mapper : in out Util.Serialize.Mappers.Processing) is
      Config : constant Controller_Config_Access := Policy.Config'Unchecked_Access;
   begin
      Mapper.Add_Mapping ("policy-rules", Perm_Mapper'Access);
      Mapper.Add_Mapping ("module", Perm_Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config.Session := AWA.Services.Contexts.Get_Session (AWA.Services.Contexts.Current);
      Config_Mapper.Set_Context (Mapper, Config);
   end Prepare_Config;

begin
   Perm_Mapper.Add_Mapping ("entity-permission", FIELD_ENTITY_PERMISSION);
   Perm_Mapper.Add_Mapping ("entity-permission/name", FIELD_NAME);
   Perm_Mapper.Add_Mapping ("entity-permission/entity-type", FIELD_ENTITY_TYPE);
   Perm_Mapper.Add_Mapping ("entity-permission/sql", FIELD_SQL);
   Perm_Mapper.Add_Mapping ("entity-permission/grant", FIELD_GRANT);
end AWA.Permissions;

Update the Prepare_Config to use the new parser/mapper interface


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

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package Util.Encoders.HMAC.SHA1 is

   pragma Preelaborate;

   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array;

   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest;

   --  Sign the data array with the key and return the HMAC-SHA256 code in the result.
   procedure Sign (Key    : in Ada.Streams.Stream_Element_Array;
                   Data   : in Ada.Streams.Stream_Element_Array;
                   Result : out Util.Encoders.SHA1.Hash_Array);

   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest;

   --  ------------------------------
   --  HMAC-SHA1 Context
   --  ------------------------------
   type Context is limited private;

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in String);

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in String);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False);

   --  ------------------------------
   --  HMAC-SHA1 encoder
   --  ------------------------------
   --  This Encoder translates the (binary) input stream into
   --  an SHA1 hexadecimal stream.  The encoding alphabet is: 0123456789ABCDEF.
   type Encoder is new Util.Encoders.Transformer with private;

   --  Encodes the binary input stream represented by Data into
   --  an SHA-1 hash output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset);

private

   type Encoder is new Util.Encoders.Transformer with null record;

   type Context is new Ada.Finalization.Limited_Controlled with record
      SHA     : Util.Encoders.SHA1.Context;
      Key     : Ada.Streams.Stream_Element_Array (0 .. 63);
      Key_Len : Ada.Streams.Stream_Element_Offset;
   end record;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context);

end Util.Encoders.HMAC.SHA1;

-----------------------------------------------------------------------
--  util-encoders-hmac-sha1 -- Compute HMAC-SHA1 authentication code
--  Copyright (C) 2011, 2012, 2017, 2019, 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.Streams;
with Ada.Finalization;
with Util.Encoders.SHA1;

--  The Util.Encodes.HMAC.SHA1 package generates HMAC-SHA1 authentication
--  (See RFC 2104 - HMAC: Keyed-Hashing for Message Authentication).
package Util.Encoders.HMAC.SHA1 is

   pragma Preelaborate;

   --  Sign the data string with the key and return the HMAC-SHA1 code in binary.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Hash_Array;

   --  Sign the data string with the key and return the HMAC-SHA1 code as hexadecimal string.
   function Sign (Key  : in String;
                  Data : in String) return Util.Encoders.SHA1.Digest;

   --  Sign the data array with the key and return the HMAC-SHA256 code in the result.
   procedure Sign (Key    : in Ada.Streams.Stream_Element_Array;
                   Data   : in Ada.Streams.Stream_Element_Array;
                   Result : out Util.Encoders.SHA1.Hash_Array);

   --  Sign the data string with the key and return the HMAC-SHA1 code as base64 string.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   function Sign_Base64 (Key  : in String;
                         Data : in String;
                         URL  : in Boolean := False) return Util.Encoders.SHA1.Base64_Digest;

   --  ------------------------------
   --  HMAC-SHA1 Context
   --  ------------------------------
   type Context is limited private;

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in String);

   --  Set the hmac private key.  The key must be set before calling any Update
   --  procedure.
   procedure Set_Key (E   : in out Context;
                      Key : in Ada.Streams.Stream_Element_Array);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in String);

   --  Update the hash with the string.
   procedure Update (E : in out Context;
                     S : in Ada.Streams.Stream_Element_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the raw binary hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Hash_Array);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the hexadecimal hash in Hash.
   procedure Finish (E    : in out Context;
                     Hash : out Util.Encoders.SHA1.Digest);

   --  Computes the HMAC-SHA1 with the private key and the data collected by
   --  the Update procedures.  Returns the base64 hash in Hash.
   --  When URL is True, use the base64 URL alphabet to encode in base64.
   procedure Finish_Base64 (E    : in out Context;
                            Hash : out Util.Encoders.SHA1.Base64_Digest;
                            URL  : in Boolean := False);

private

   type Encoder is new Util.Encoders.Transformer with null record;

   type Context is new Ada.Finalization.Limited_Controlled with record
      SHA     : Util.Encoders.SHA1.Context;
      Key     : Ada.Streams.Stream_Element_Array (0 .. 63);
      Key_Len : Ada.Streams.Stream_Element_Offset;
   end record;

   --  Initialize the SHA-1 context.
   overriding
   procedure Initialize (E : in out Context);

end Util.Encoders.HMAC.SHA1;

Remove the Encoder type and its operation because it was never implemented


-----------------------------------------------------------------------
--  mat-readers-marshaller -- Marshalling of data in communication buffer
--  Copyright (C) 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 Ada.Strings.Unbounded;
with MAT.Types;
with MAT.Events;
package MAT.Readers.Marshaller is

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   --  Get an 8-bit value from the buffer.
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   --  Get a 16-bit value either from big-endian or little endian.
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   --  Get a 32-bit value either from big-endian or little endian.
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   --  Get a 64-bit value either from big-endian or little endian.
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Buffer_Ptr) return String;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Msg : in Buffer_Ptr) return Ada.Strings.Unbounded.Unbounded_String;

   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Buffer_Ptr;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;

   function Get_Target_Size (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size;

   function Get_Target_Addr (Msg  : in Buffer_Ptr;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr;

   function Get_Target_Uint32 (Msg  : in Buffer_Ptr;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32;

   --  Skip the given number of bytes from the message.
   procedure Skip (Buffer : in Buffer_Ptr;
                   Size   : in Natural);

end MAT.Readers.Marshaller;

-----------------------------------------------------------------------
--  mat-readers-marshaller -- Marshalling of data in communication buffer
--  Copyright (C) 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 Ada.Strings.Unbounded;
with MAT.Types;
with MAT.Events;
package MAT.Readers.Marshaller is

   Buffer_Underflow_Error : exception;

   Buffer_Overflow_Error : exception;

   --  Get an 8-bit value from the buffer.
   function Get_Uint8 (Buffer : in Buffer_Ptr) return MAT.Types.Uint8;

   --  Get a 16-bit value either from big-endian or little endian.
   function Get_Uint16 (Buffer : in Buffer_Ptr) return MAT.Types.Uint16;

   --  Get a 32-bit value either from big-endian or little endian.
   function Get_Uint32 (Buffer : in Buffer_Ptr) return MAT.Types.Uint32;

   --  Get a 64-bit value either from big-endian or little endian.
   function Get_Uint64 (Buffer : in Buffer_Ptr) return MAT.Types.Uint64;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Buffer : in Message_Type) return String;

   --  Extract a string from the buffer.  The string starts with a byte that
   --  indicates the string length.
   function Get_String (Msg : in Message_Type) return Ada.Strings.Unbounded.Unbounded_String;

   generic
      type Target_Type is mod <>;
   function Get_Target_Value (Msg  : in Message_Type;
                              Kind : in MAT.Events.Attribute_Type) return Target_Type;

   function Get_Target_Size (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Size;

   function Get_Target_Addr (Msg  : in Message_Type;
                             Kind : in MAT.Events.Attribute_Type) return MAT.Types.Target_Addr;

   function Get_Target_Uint32 (Msg  : in Message_Type;
                               Kind : in MAT.Events.Attribute_Type) return MAT.Types.Uint32;

   --  Skip the given number of bytes from the message.
   procedure Skip (Buffer : in Message_Type;
                   Size   : in Natural);

end MAT.Readers.Marshaller;

Change the Get_xx operation to use the Message_Type as parameter


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

with Ada.Finalization;
with Babel.Files.Buffers;
package Babel.Streams is

   type Stream_Type is abstract tagged limited private;
   type Stream_Access is access all Stream_Type'Class;

   --  Read the data stream as much as possible and return the result in a buffer.
   --  The buffer is owned by the stream and need not be released.  The same buffer may
   --  or may not be returned by the next <tt>Read</tt> operation.
   --  A null buffer is returned when the end of the data stream is reached.
   procedure Read (Stream : in out Stream_Type;
                   Buffer : out Babel.Files.Buffers.Buffer_Access) is abstract;

   --  Write the buffer in the data stream.
   procedure Write (Stream : in out Stream_Type;
                    Buffer : in Babel.Files.Buffers.Buffer_Access) is abstract;

   --  Flush the data stream.
   procedure Flush (Stream : in out Stream_Type) is null;

   --  Close the data stream.
   procedure Close (Stream : in out Stream_Type) is null;

   --  Prepare to read again the data stream from the beginning.
   procedure Rewind (Stream : in out Stream_Type) is null;

   --  Set the internal buffer that the stream can use.
   procedure Set_Buffer (Stream : in out Stream_Type;
                         Buffer : in Babel.Files.Buffers.Buffer_Access);

private

   type Stream_Type is abstract limited new Ada.Finalization.Limited_Controlled with record
      Buffer  : Babel.Files.Buffers.Buffer_Access;
   end record;

   --  Release the stream buffer if there is one.
   overriding
   procedure Finalize (Stream : in out Stream_Type);

end Babel.Streams;

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

with Ada.Finalization;
with Util.Refs;
with Babel.Files.Buffers;
package Babel.Streams is

   type Stream_Type is abstract limited new Util.Refs.Ref_Entity with private;
   type Stream_Access is access all Stream_Type'Class;

   --  Read the data stream as much as possible and return the result in a buffer.
   --  The buffer is owned by the stream and need not be released.  The same buffer may
   --  or may not be returned by the next <tt>Read</tt> operation.
   --  A null buffer is returned when the end of the data stream is reached.
   procedure Read (Stream : in out Stream_Type;
                   Buffer : out Babel.Files.Buffers.Buffer_Access) is abstract;

   --  Write the buffer in the data stream.
   procedure Write (Stream : in out Stream_Type;
                    Buffer : in Babel.Files.Buffers.Buffer_Access) is abstract;

   --  Flush the data stream.
   procedure Flush (Stream : in out Stream_Type) is null;

   --  Close the data stream.
   procedure Close (Stream : in out Stream_Type) is null;

   --  Prepare to read again the data stream from the beginning.
   procedure Rewind (Stream : in out Stream_Type) is null;

   --  Set the internal buffer that the stream can use.
   procedure Set_Buffer (Stream : in out Stream_Type;
                         Buffer : in Babel.Files.Buffers.Buffer_Access);

private

   type Stream_Type is abstract limited new Util.Refs.Ref_Entity with record
      Buffer  : Babel.Files.Buffers.Buffer_Access;
   end record;

   --  Release the stream buffer if there is one.
   overriding
   procedure Finalize (Stream : in out Stream_Type);

end Babel.Streams;

Use the Util.Refs.Ref_Entity for reference counting


-----------------------------------------------------------------------
--  ADO Sessions -- Sessions Management
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014, 2015, 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.Log;
with Util.Log.Loggers;
with Ada.Unchecked_Deallocation;

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

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

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

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

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

   --  ------------------------------
   --  Get the database driver which manages this connection.
   --  ------------------------------
   function Get_Driver (Database : in Session) return ADO.Drivers.Connections.Driver_Access is
   begin
      if Database.Impl = null or else Database.Impl.Database.Is_Null then
         return null;
      else
         return Database.Impl.Database.Value.Get_Driver;
      end if;
   end Get_Driver;

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

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

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

   --  ------------------------------
   --  Insert a new cache in the manager.  The cache is identified by the given name.
   --  ------------------------------
   procedure Add_Cache (Database : in out Session;
                        Name     : in String;
                        Cache    : in ADO.Caches.Cache_Type_Access) is
   begin
      Check_Session (Database);
      Database.Impl.Values.Add_Cache (Name, Cache);
   end Add_Cache;

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

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

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

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Query : constant Query_Statement_Access := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Query, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create a query statement.  The statement is not prepared
   --  ------------------------------
   function Create_Statement (Database : in Session;
                              Query    : in String)
                              return Query_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Query_Statement_Access := Database.Impl.Database.Value.all.Create_Statement (Query);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

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

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

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

   --  ------------------------------
   --  Load the database schema definition for the current database.
   --  ------------------------------
   procedure Load_Schema (Database : in Session;
                          Schema   : out ADO.Schemas.Schema_Definition) is
   begin
      Check_Session (Database, "Loading schema {0}");
      Database.Impl.Database.Value.Load_Schema (Schema);
   end Load_Schema;

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

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

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

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

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

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

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

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

   --  ------------------------------
   --  Create a delete statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Delete_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Delete_Statement_Access := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an update statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Update_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Update_Statement_Access := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

   --  ------------------------------
   --  Create an insert statement
   --  ------------------------------
   function Create_Statement (Database : in Master_Session;
                              Table    : in ADO.Schemas.Class_Mapping_Access)
                              return Insert_Statement is
   begin
      Check_Session (Database);
      declare
         Stmt : constant Insert_Statement_Access := Database.Impl.Database.Value.all.Create_Statement (Table);
      begin
         return ADO.Statements.Create.Create_Statement (Stmt.all'Access, Database.Impl.Values.all'Access);
      end;
   end Create_Statement;

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

end ADO.Sessions;

Fix style compilation warning

Fix style compilation warning