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

with ASF.Requests;
with ASF.Responses;
with ASF.Sessions;
limited with ASF.Converters;
with ASF.Components.Root;
limited with ASF.Applications.Main;
with ASF.Applications.Messages;
with ASF.Applications.Messages.Vectors;
with ASF.Contexts.Writer;
with ASF.Contexts.Exceptions;
limited with ASF.Contexts.Flash;
with ASF.Events.Exceptions;
with ASF.Events.Phases;

with EL.Objects;
with EL.Contexts;
with Util.Locales;
with Util.Beans.Basic;

with Ada.Exceptions;
with Ada.Strings.Unbounded;

private with Ada.Finalization;
private with Ada.Strings.Unbounded.Hash;
private with Ada.Containers.Hashed_Maps;

--  The Faces_Context is an object passed to the component tree and
--  bean actions to provide the full context in which the view is rendered
--  or evaluated.  The faces context gives access to the bean variables,
--  the request and its parameters, the response writer to write on the
--  output stream.
--
--  The Faces_Context is never shared: it is specific to each request.
package ASF.Contexts.Faces is

   use Ada.Strings.Unbounded;

   type Application_Access is access all ASF.Applications.Main.Application'Class;
   type Flash_Context_Access is access all ASF.Contexts.Flash.Flash_Context'Class;

   type Faces_Context is tagged limited private;

   type Faces_Context_Access is access all Faces_Context'Class;

   --  Get the response writer to write the response stream.
   function Get_Response_Writer (Context : Faces_Context)
     return ASF.Contexts.Writer.Response_Writer_Access;

   --  Set the response writer to write to the response stream.
   procedure Set_Response_Writer (Context : in out Faces_Context;
                                  Writer  : in ASF.Contexts.Writer.Response_Writer_Access);

   --  Get the EL context for evaluating expressions.
   function Get_ELContext (Context : in Faces_Context)
                           return EL.Contexts.ELContext_Access;

   --  Set the EL context for evaluating expressions.
   procedure Set_ELContext (Context   : in out Faces_Context;
                            ELContext : in EL.Contexts.ELContext_Access);

   --  Set the attribute having given name with the value.
   procedure Set_Attribute (Context : in out Faces_Context;
                            Name    : in String;
                            Value   : in EL.Objects.Object);

   --  Set the attribute having given name with the value.
   procedure Set_Attribute (Context : in out Faces_Context;
                            Name    : in Unbounded_String;
                            Value   : in EL.Objects.Object);

   --  Get the attribute with the given name.
   function Get_Attribute (Context : in Faces_Context;
                           Name    : in String) return EL.Objects.Object;

   --  Get the attribute with the given name.
   function Get_Attribute (Context : in Faces_Context;
                           Name    : in Unbounded_String) return EL.Objects.Object;

   --  Get the bean attribute with the given name.
   --  Returns null if the attribute does not exist or is not a bean.
   function Get_Bean (Context : in Faces_Context;
                      Name    : in String) return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a request parameter
   function Get_Parameter (Context : Faces_Context;
                           Name    : String) return String;

   --  Get the session associated with the current faces context.
   function Get_Session (Context : in Faces_Context;
                         Create  : in Boolean := False) return ASF.Sessions.Session;

   --  Get the request
   function Get_Request (Context : Faces_Context) return ASF.Requests.Request_Access;

   --  Set the request
   procedure Set_Request (Context : in out Faces_Context;
                          Request : in ASF.Requests.Request_Access);

   --  Get the response
   function Get_Response (Context : Faces_Context) return ASF.Responses.Response_Access;

   --  Set the response
   procedure Set_Response (Context  : in out Faces_Context;
                           Response : in ASF.Responses.Response_Access);

   --  Signal the JavaServer faces implementation that, as soon as the
   --  current phase of the request processing lifecycle has been completed,
   --  control should be passed to the Render Response phase,
   --  bypassing any phases that have not been executed yet.
   procedure Render_Response (Context : in out Faces_Context);

   --  Check whether the Render_Response phase must be processed immediately.
   function Get_Render_Response (Context : in Faces_Context) return Boolean;

   --  Signal the JavaServer Faces implementation that the HTTP response
   --  for this request has already been generated (such as an HTTP redirect),
   --  and that the request processing lifecycle should be terminated as soon
   --  as the current phase is completed.
   procedure Response_Completed (Context : in out Faces_Context);

   --  Check whether the response has been completed.
   function Get_Response_Completed (Context : in Faces_Context) return Boolean;

   --  Get the flash context allowing to add flash attributes.
   function Get_Flash (Context : in Faces_Context) return Flash_Context_Access;

   --  Set the flash context.
   procedure Set_Flash (Context : in out Faces_Context;
                        Flash   : in Flash_Context_Access);

   --  Append the message to the list of messages associated with the specified
   --  client identifier.  If Client_Id is empty, the message is global
   --  (or not associated with a component)
   procedure Add_Message (Context   : in out Faces_Context;
                          Client_Id : in String;
                          Message   : in ASF.Applications.Messages.Message);

   --  Append the message to the list of messages associated with the specified
   --  client identifier.  If Client_Id is empty, the message is global
   --  (or not associated with a component)
   procedure Add_Message (Context   : in out Faces_Context;
                          Client_Id : in String;
                          Message   : in String;
                          Severity  : in Applications.Messages.Severity
                          := Applications.Messages.ERROR);

   --  Append the messages defined in Messages to the current list of messages
   --  in the faces context.
   procedure Add_Messages (Context   : in out Faces_Context;
                           Client_Id : in String;
                           Messages  : in ASF.Applications.Messages.Vectors.Vector);

   --  Get an iterator for the messages associated with the specified client
   --  identifier.  If the Client_Id ie empty, an iterator for the
   --  global messages is returned.
   function Get_Messages (Context   : in Faces_Context;
                          Client_Id : in String) return ASF.Applications.Messages.Vectors.Cursor;

   --  Returns the maximum severity level recorded for any message that has been queued.
   --  Returns NONE if no message has been queued.
   function Get_Maximum_Severity (Context : in Faces_Context)
                                  return ASF.Applications.Messages.Severity;

   --  Get a converter from a name.
   --  Returns the converter object or null if there is no converter.
   function Get_Converter (Context : in Faces_Context;
                           Name    : in EL.Objects.Object)
                           return access ASF.Converters.Converter'Class;

   --  Get the application associated with this faces context.
   function Get_Application (Context : in Faces_Context)
                             return Application_Access;

   --  Get the current lifecycle phase.
   function Get_Current_Phase (Context : in Faces_Context) return ASF.Events.Phases.Phase_Type;

   --  Set the current lifecycle phase.  This operation is called by the lifecycle manager
   --  each time the lifecycle phase changes.
   procedure Set_Current_Phase (Context : in out Faces_Context;
                                Phase   : in ASF.Events.Phases.Phase_Type);

   --  Get the locale defined by the view root component.
   --  Returns the NULL_LOCALE if there is no view root component.
   function Get_Locale (Context : in Faces_Context) return Util.Locales.Locale;

   --  Set the locale that must be used when rendering the view components.
   procedure Set_Locale (Context : in out Faces_Context;
                         Locale  : in Util.Locales.Locale);

   --  Get the component view root.
   function Get_View_Root (Context : in Faces_Context)
                           return ASF.Components.Root.UIViewRoot;

   --  Get the component view root.
   procedure Set_View_Root (Context : in out Faces_Context;
                            View    : in ASF.Components.Root.UIViewRoot);

   --  Create an identifier for a component.
   procedure Create_Unique_Id (Context : in out Faces_Context;
                               Id      : out Natural);

   --  Set the exception handler that will receive unexpected exceptions and process them.
   procedure Set_Exception_Handler (Context : in out Faces_Context;
                                    Handler : in Exceptions.Exception_Handler_Access);

   --  Get the exception handler.
   function Get_Exception_Handler (Context : in Faces_Context)
                                   return Exceptions.Exception_Handler_Access;

   --  Queue an exception event to the exception handler associated with the context.
   --  The exception event will be processed at the end of the current ASF phase.
   procedure Queue_Exception (Context : in out Faces_Context;
                              Ex      : in Ada.Exceptions.Exception_Occurrence);

   --  Iterate over the exceptions that have been queued and execute the Process
   --  procedure.  When the procedure returns True in Remove</b, the exception event
   --  is removed from the queue.  The procedure can update the faces context to add some
   --  error message or redirect to an error page.
   --
   --  The application exception handler uses this procedure to process the exceptions.
   --  The exception handler is called after each ASF phase.
   procedure Iterate_Exception (Context : in out Faces_Context'Class;
                                Process : not null access
                                  procedure (Event   : in Events.Exceptions.Exception_Event'Class;
                                             Remove  : out Boolean;
                                             Context : in out Faces_Context'Class));

   --  Returns True if the current request is an AJAX request.
   function Is_Ajax_Request (Context : in Faces_Context'Class) return Boolean;

   --  Set the Ajax request status.
   procedure Set_Ajax_Request (Context : in out Faces_Context'Class;
                               Status  : in Boolean);

   --  Get the current faces context.  The faces context is saved
   --  in a per-thread/task attribute.
   function Current return Faces_Context_Access;

   --  Set the current faces context in the per-thread/task attribute.
   procedure Set_Current (Context     : in Faces_Context_Access;
                          Application : in Application_Access);

   --  Restore the previous faces context.
   procedure Restore (Context : in Faces_Context_Access);

private

   use ASF.Applications.Messages;

   type Exception_Queue_Access is access ASF.Contexts.Exceptions.Exception_Queue;

   --  Map of messages associated with a component
   package Message_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                 Element_Type    => Vectors.Vector,
                                 Hash            => Hash,
                                 Equivalent_Keys => "=",
                                 "="             => Vectors."=");

   type Faces_Context is new Ada.Finalization.Limited_Controlled with record
      --  The response writer.
      Writer   : ASF.Contexts.Writer.Response_Writer_Access;

      --  The expression context;
      Context  : EL.Contexts.ELContext_Access;

      --  The request
      Request  : ASF.Requests.Request_Access;

      --  The response
      Response : ASF.Responses.Response_Access;

      --  The application
      Application : Application_Access;

      --  The exception handler and exception queue.
      Except_Handler     : Exceptions.Exception_Handler_Access;
      Except_Queue       : Exception_Queue_Access;

      Render_Response    : Boolean := False;
      Response_Completed : Boolean := False;

      --  True if the view is processed as part of an AJAX request.
      Ajax               : Boolean := False;

      --  List of messages added indexed by the client identifier.
      Messages           : Message_Maps.Map;

      --  The maximum severity for the messages that were collected.
      Max_Severity       : Severity := NONE;

      Root               : ASF.Components.Root.UIViewRoot;

      --  The flash context.
      Flash              : Flash_Context_Access;

      --  The current lifecycle phase.
      Phase              : ASF.Events.Phases.Phase_Type := ASF.Events.Phases.RESTORE_VIEW;

      --  The locale defined by the view root component.  Unlike JSF, we store the locale
      --  in the faces context.  This is easier for the implementation.
      Locale             : Util.Locales.Locale := Util.Locales.NULL_LOCALE;
   end record;

   --  Release any storage held by this context.
   overriding
   procedure Finalize (Context : in out Faces_Context);

end ASF.Contexts.Faces;

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

with ASF.Requests;
with ASF.Responses;
with ASF.Sessions;
limited with ASF.Converters;
with ASF.Components.Root;
limited with ASF.Applications.Main;
with ASF.Applications.Messages;
with ASF.Applications.Messages.Vectors;
with ASF.Contexts.Writer;
with ASF.Contexts.Exceptions;
limited with ASF.Contexts.Flash;
with ASF.Events.Exceptions;
with ASF.Events.Phases;

with EL.Objects;
with EL.Contexts;
with Util.Locales;
with Util.Beans.Basic;

with Ada.Exceptions;
with Ada.Strings.Unbounded;

private with Ada.Finalization;
private with Ada.Strings.Unbounded.Hash;
private with Ada.Containers.Hashed_Maps;

--  The Faces_Context is an object passed to the component tree and
--  bean actions to provide the full context in which the view is rendered
--  or evaluated.  The faces context gives access to the bean variables,
--  the request and its parameters, the response writer to write on the
--  output stream.
--
--  The Faces_Context is never shared: it is specific to each request.
package ASF.Contexts.Faces is

   use Ada.Strings.Unbounded;

   type Application_Access is access all ASF.Applications.Main.Application'Class;
   type Flash_Context_Access is access all ASF.Contexts.Flash.Flash_Context'Class;

   type Faces_Context is tagged limited private;

   type Faces_Context_Access is access all Faces_Context'Class;

   --  Get the response writer to write the response stream.
   function Get_Response_Writer (Context : Faces_Context)
     return ASF.Contexts.Writer.Response_Writer_Access;

   --  Set the response writer to write to the response stream.
   procedure Set_Response_Writer (Context : in out Faces_Context;
                                  Writer  : in ASF.Contexts.Writer.Response_Writer_Access);

   --  Get the EL context for evaluating expressions.
   function Get_ELContext (Context : in Faces_Context)
                           return EL.Contexts.ELContext_Access;

   --  Set the EL context for evaluating expressions.
   procedure Set_ELContext (Context   : in out Faces_Context;
                            ELContext : in EL.Contexts.ELContext_Access);

   --  Set the attribute having given name with the value.
   procedure Set_Attribute (Context : in out Faces_Context;
                            Name    : in String;
                            Value   : in EL.Objects.Object);

   --  Set the attribute having given name with the value.
   procedure Set_Attribute (Context : in out Faces_Context;
                            Name    : in Unbounded_String;
                            Value   : in EL.Objects.Object);

   --  Get the attribute with the given name.
   function Get_Attribute (Context : in Faces_Context;
                           Name    : in String) return EL.Objects.Object;

   --  Get the attribute with the given name.
   function Get_Attribute (Context : in Faces_Context;
                           Name    : in Unbounded_String) return EL.Objects.Object;

   --  Get the bean attribute with the given name.
   --  Returns null if the attribute does not exist or is not a bean.
   function Get_Bean (Context : in Faces_Context;
                      Name    : in String) return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a request parameter
   function Get_Parameter (Context : Faces_Context;
                           Name    : String) return String;

   --  Get the session associated with the current faces context.
   function Get_Session (Context : in Faces_Context;
                         Create  : in Boolean := False) return ASF.Sessions.Session;

   --  Get the request
   function Get_Request (Context : Faces_Context) return ASF.Requests.Request_Access;

   --  Set the request
   procedure Set_Request (Context : in out Faces_Context;
                          Request : in ASF.Requests.Request_Access);

   --  Get the response
   function Get_Response (Context : Faces_Context) return ASF.Responses.Response_Access;

   --  Set the response
   procedure Set_Response (Context  : in out Faces_Context;
                           Response : in ASF.Responses.Response_Access);

   --  Signal the JavaServer faces implementation that, as soon as the
   --  current phase of the request processing lifecycle has been completed,
   --  control should be passed to the Render Response phase,
   --  bypassing any phases that have not been executed yet.
   procedure Render_Response (Context : in out Faces_Context);

   --  Check whether the Render_Response phase must be processed immediately.
   function Get_Render_Response (Context : in Faces_Context) return Boolean;

   --  Signal the JavaServer Faces implementation that the HTTP response
   --  for this request has already been generated (such as an HTTP redirect),
   --  and that the request processing lifecycle should be terminated as soon
   --  as the current phase is completed.
   procedure Response_Completed (Context : in out Faces_Context);

   --  Check whether the response has been completed.
   function Get_Response_Completed (Context : in Faces_Context) return Boolean;

   --  Get the flash context allowing to add flash attributes.
   function Get_Flash (Context : in Faces_Context) return Flash_Context_Access;

   --  Set the flash context.
   procedure Set_Flash (Context : in out Faces_Context;
                        Flash   : in Flash_Context_Access);

   --  Append the message to the list of messages associated with the specified
   --  client identifier.  If Client_Id is empty, the message is global
   --  (or not associated with a component)
   procedure Add_Message (Context   : in out Faces_Context;
                          Client_Id : in String;
                          Message   : in ASF.Applications.Messages.Message);

   --  Append the message to the list of messages associated with the specified
   --  client identifier.  If Client_Id is empty, the message is global
   --  (or not associated with a component)
   procedure Add_Message (Context   : in out Faces_Context;
                          Client_Id : in String;
                          Message   : in String;
                          Severity  : in Applications.Messages.Severity
                          := Applications.Messages.ERROR);

   --  Append the messages defined in Messages to the current list of messages
   --  in the faces context.
   procedure Add_Messages (Context   : in out Faces_Context;
                           Client_Id : in String;
                           Messages  : in ASF.Applications.Messages.Vectors.Vector);

   --  Get an iterator for the messages associated with the specified client
   --  identifier.  If the Client_Id ie empty, an iterator for the
   --  global messages is returned.
   function Get_Messages (Context   : in Faces_Context;
                          Client_Id : in String) return ASF.Applications.Messages.Vectors.Cursor;

   --  Returns the maximum severity level recorded for any message that has been queued.
   --  Returns NONE if no message has been queued.
   function Get_Maximum_Severity (Context : in Faces_Context)
                                  return ASF.Applications.Messages.Severity;

   --  Get a converter from a name.
   --  Returns the converter object or null if there is no converter.
   function Get_Converter (Context : in Faces_Context;
                           Name    : in EL.Objects.Object)
                           return access ASF.Converters.Converter'Class;

   --  Get the application associated with this faces context.
   function Get_Application (Context : in Faces_Context)
                             return Application_Access;

   --  Get the current lifecycle phase.
   function Get_Current_Phase (Context : in Faces_Context) return ASF.Events.Phases.Phase_Type;

   --  Set the current lifecycle phase.  This operation is called by the lifecycle manager
   --  each time the lifecycle phase changes.
   procedure Set_Current_Phase (Context : in out Faces_Context;
                                Phase   : in ASF.Events.Phases.Phase_Type);

   --  Get the locale defined by the view root component.
   --  Returns the NULL_LOCALE if there is no view root component.
   function Get_Locale (Context : in Faces_Context) return Util.Locales.Locale;

   --  Set the locale that must be used when rendering the view components.
   procedure Set_Locale (Context : in out Faces_Context;
                         Locale  : in Util.Locales.Locale);

   --  Get the component view root.
   function Get_View_Root (Context : in Faces_Context)
                           return ASF.Components.Root.UIViewRoot;

   --  Get the component view root.
   procedure Set_View_Root (Context : in out Faces_Context;
                            View    : in ASF.Components.Root.UIViewRoot);

   --  Get the view name associated with the current faces request.
   --  The view name is obtained from the request and the route mapping definition.
   --  If a pretty URL configuration was set through the `url-mapping` definition, the view
   --  name correspond to the `view-id` declaration.  Otherwise, the view name corresponds
   --  to the servlet's path.
   function Get_View_Name (Context : in Faces_Context) return String;

   --  Create an identifier for a component.
   procedure Create_Unique_Id (Context : in out Faces_Context;
                               Id      : out Natural);

   --  Set the exception handler that will receive unexpected exceptions and process them.
   procedure Set_Exception_Handler (Context : in out Faces_Context;
                                    Handler : in Exceptions.Exception_Handler_Access);

   --  Get the exception handler.
   function Get_Exception_Handler (Context : in Faces_Context)
                                   return Exceptions.Exception_Handler_Access;

   --  Queue an exception event to the exception handler associated with the context.
   --  The exception event will be processed at the end of the current ASF phase.
   procedure Queue_Exception (Context : in out Faces_Context;
                              Ex      : in Ada.Exceptions.Exception_Occurrence);

   --  Iterate over the exceptions that have been queued and execute the Process
   --  procedure.  When the procedure returns True in Remove</b, the exception event
   --  is removed from the queue.  The procedure can update the faces context to add some
   --  error message or redirect to an error page.
   --
   --  The application exception handler uses this procedure to process the exceptions.
   --  The exception handler is called after each ASF phase.
   procedure Iterate_Exception (Context : in out Faces_Context'Class;
                                Process : not null access
                                  procedure (Event   : in Events.Exceptions.Exception_Event'Class;
                                             Remove  : out Boolean;
                                             Context : in out Faces_Context'Class));

   --  Returns True if the current request is an AJAX request.
   function Is_Ajax_Request (Context : in Faces_Context'Class) return Boolean;

   --  Set the Ajax request status.
   procedure Set_Ajax_Request (Context : in out Faces_Context'Class;
                               Status  : in Boolean);

   --  Get the current faces context.  The faces context is saved
   --  in a per-thread/task attribute.
   function Current return Faces_Context_Access;

   --  Set the current faces context in the per-thread/task attribute.
   procedure Set_Current (Context     : in Faces_Context_Access;
                          Application : in Application_Access);

   --  Restore the previous faces context.
   procedure Restore (Context : in Faces_Context_Access);

private

   use ASF.Applications.Messages;

   type Exception_Queue_Access is access ASF.Contexts.Exceptions.Exception_Queue;

   --  Map of messages associated with a component
   package Message_Maps is new
     Ada.Containers.Hashed_Maps (Key_Type        => Unbounded_String,
                                 Element_Type    => Vectors.Vector,
                                 Hash            => Hash,
                                 Equivalent_Keys => "=",
                                 "="             => Vectors."=");

   type Faces_Context is new Ada.Finalization.Limited_Controlled with record
      --  The response writer.
      Writer   : ASF.Contexts.Writer.Response_Writer_Access;

      --  The expression context;
      Context  : EL.Contexts.ELContext_Access;

      --  The request
      Request  : ASF.Requests.Request_Access;

      --  The response
      Response : ASF.Responses.Response_Access;

      --  The application
      Application : Application_Access;

      --  The exception handler and exception queue.
      Except_Handler     : Exceptions.Exception_Handler_Access;
      Except_Queue       : Exception_Queue_Access;

      Render_Response    : Boolean := False;
      Response_Completed : Boolean := False;

      --  True if the view is processed as part of an AJAX request.
      Ajax               : Boolean := False;

      --  List of messages added indexed by the client identifier.
      Messages           : Message_Maps.Map;

      --  The maximum severity for the messages that were collected.
      Max_Severity       : Severity := NONE;

      Root               : ASF.Components.Root.UIViewRoot;

      --  The flash context.
      Flash              : Flash_Context_Access;

      --  The current lifecycle phase.
      Phase              : ASF.Events.Phases.Phase_Type := ASF.Events.Phases.RESTORE_VIEW;

      --  The locale defined by the view root component.  Unlike JSF, we store the locale
      --  in the faces context.  This is easier for the implementation.
      Locale             : Util.Locales.Locale := Util.Locales.NULL_LOCALE;
   end record;

   --  Release any storage held by this context.
   overriding
   procedure Finalize (Context : in out Faces_Context);

end ASF.Contexts.Faces;

Declare the Get_View_Name function to retrieve the request view name


-----------------------------------------------------------------------
--  security-controllers -- Controllers to verify a security permission
--  Copyright (C) 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 Security.Contexts;

--  == Security Controller ==
--  The Security.Controllers package defines the security controller used to
--  verify that a given permission is granted.  A security controller uses the security
--  context and other controller specific and internal data to verify that the permission
--  is granted.
--
--  To implement a new security controller, one must:
--
--    * Define a type that implements the Controller interface with the
--      Has_Permission operation
--    * Write a function to allocate instances of the given Controller type
--    * Register the function under a unique name by using Register_Controller
--
--  Security controller instances are created when the security policy rules are parsed.
--  These instances are shared across possibly several concurrent requests.
package Security.Controllers is

   Invalid_Controller : exception;

   --  ------------------------------
   --  Security Controller interface
   --  ------------------------------
   type Controller is limited interface;
   type Controller_Access is access all Controller'Class;

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

   type Controller_Factory is not null access function return Controller_Access;

   --  To keep this implementation simple, a maximum of 32 security controller factory
   --  can be registered.  ASF provides one based on roles.  AWA provides another one
   --  based on entity ACLs.
   MAX_CONTROLLER_FACTORY : constant Positive := 32;

   --  Register in a global table the controller factory under the name Name.
   --  When this factory is used, the Factory operation will be called to
   --  create new instances of the controller.
   procedure Register_Controller (Name    : in String;
                                  Factory : in Controller_Factory);

   --  Create a security controller by using the controller factory registered under
   --  the name Name.
   --  Raises Invalid_Controller if the name is not recognized.
   function Create_Controller (Name : in String) return Controller_Access;

end Security.Controllers;

-----------------------------------------------------------------------
--  security-controllers -- Controllers to verify a security permission
--  Copyright (C) 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 Security.Contexts;
with Security.Permissions;

--  == Security Controller ==
--  The Security.Controllers package defines the security controller used to
--  verify that a given permission is granted.  A security controller uses the security
--  context and other controller specific and internal data to verify that the permission
--  is granted.
--
--  To implement a new security controller, one must:
--
--    * Define a type that implements the Controller interface with the
--      Has_Permission operation
--    * Write a function to allocate instances of the given Controller type
--    * Register the function under a unique name by using Register_Controller
--
--  Security controller instances are created when the security policy rules are parsed.
--  These instances are shared across possibly several concurrent requests.
package Security.Controllers is

   Invalid_Controller : exception;

   --  ------------------------------
   --  Security Controller interface
   --  ------------------------------
   type Controller is limited interface;
   type Controller_Access is access all Controller'Class;

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

   type Controller_Factory is not null access function return Controller_Access;

   --  To keep this implementation simple, a maximum of 32 security controller factory
   --  can be registered.  ASF provides one based on roles.  AWA provides another one
   --  based on entity ACLs.
   MAX_CONTROLLER_FACTORY : constant Positive := 32;

   --  Register in a global table the controller factory under the name Name.
   --  When this factory is used, the Factory operation will be called to
   --  create new instances of the controller.
   procedure Register_Controller (Name    : in String;
                                  Factory : in Controller_Factory);

   --  Create a security controller by using the controller factory registered under
   --  the name Name.
   --  Raises Invalid_Controller if the name is not recognized.
   function Create_Controller (Name : in String) return Controller_Access;

end Security.Controllers;

Fix compilation

Fix compilation


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

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Sessions.Entities;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Audits.Model;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T1 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.AUDIT_TABLE);
         T2 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.EMAIL_TABLE);
         T3 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Name    => "audit_property");
      begin
         T.Assert (T1 > 0, "T1 must be positive");
         T.Assert (T2 > 0, "T2 must be positive");
         T.Assert (T3 > 0, "T3 must be positive");
         T.Assert (T4 > 0, "T4 must be positive");
         T.Assert (T5 > 0, "T5 must be positive");

         T.Assert (T1 /= T2, "Two distinct tables have different entity types (T1, T2)");
         T.Assert (T2 /= T3, "Two distinct tables have different entity types (T2, T3)");
         T.Assert (T3 /= T4, "Two distinct tables have different entity types (T3, T4)");
         T.Assert (T4 /= T5, "Two distinct tables have different entity types (T4, T5)");
         T.Assert (T5 /= T1, "Two distinct tables have different entity types (T5, T1)");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 21, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 10, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 10, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

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

with Util.Test_Caller;
with Util.Strings.Vectors;
with Util.Strings.Transforms;

with ADO.Parameters;
with ADO.Schemas.Databases;
with ADO.Sessions.Sources;
with ADO.Sessions.Entities;
with ADO.Schemas.Entities;

with Regtests;
with Regtests.Audits.Model;
with Regtests.Simple.Model;
package body ADO.Schemas.Tests is

   use Util.Tests;

   function To_Lower_Case (S : in String) return String
     renames Util.Strings.Transforms.To_Lower_Case;

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type",
                       Test_Find_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Entities.Find_Entity_Type (error)",
                       Test_Find_Entity_Type_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Sessions.Load_Schema",
                       Test_Load_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table",
                       Test_Table_Iterator'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Get_Table (Empty schema)",
                       Test_Empty_Schema'Access);
      Caller.Add_Test (Suite, "Test ADO.Schemas.Databases.Create_Database",
                       Test_Create_Schema'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading the entity cache and the Find_Entity_Type operation
   --  ------------------------------
   procedure Test_Find_Entity_Type (T : in out Test) is
      S   : ADO.Sessions.Session := Regtests.Get_Database;
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      ADO.Schemas.Entities.Initialize (Cache   => C,
                                       Session => S);

      declare
         T4 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.ALLOCATE_TABLE);
         T5 : constant ADO.Entity_Type
           := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T1 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.AUDIT_TABLE);
         T2 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Table   => Regtests.Audits.Model.EMAIL_TABLE);
         T3 : constant ADO.Entity_Type
           := Sessions.Entities.Find_Entity_Type (Session => S,
                                                  Name    => "audit_property");
      begin
         T.Assert (T1 > 0, "T1 must be positive");
         T.Assert (T2 > 0, "T2 must be positive");
         T.Assert (T3 > 0, "T3 must be positive");
         T.Assert (T4 > 0, "T4 must be positive");
         T.Assert (T5 > 0, "T5 must be positive");

         T.Assert (T1 /= T2, "Two distinct tables have different entity types (T1, T2)");
         T.Assert (T2 /= T3, "Two distinct tables have different entity types (T2, T3)");
         T.Assert (T3 /= T4, "Two distinct tables have different entity types (T3, T4)");
         T.Assert (T4 /= T5, "Two distinct tables have different entity types (T4, T5)");
         T.Assert (T5 /= T1, "Two distinct tables have different entity types (T5, T1)");
      end;
   end Test_Find_Entity_Type;

   --  ------------------------------
   --  Test calling Find_Entity_Type with an invalid table.
   --  ------------------------------
   procedure Test_Find_Entity_Type_Error (T : in out Test) is
      C   : ADO.Schemas.Entities.Entity_Cache;
   begin
      declare
         R : ADO.Entity_Type;
         pragma Unreferenced (R);
      begin
         R := Entities.Find_Entity_Type (Cache => C,
                                         Table => Regtests.Simple.Model.USER_TABLE);
         T.Assert (False, "Find_Entity_Type did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;

      declare
         P : ADO.Parameters.Parameter
           := ADO.Parameters.Parameter'(T => ADO.Parameters.T_INTEGER, Num => 0,
                                        Len => 0, Value_Len => 0, Position => 0, Name => "");
      begin
         P := C.Expand ("something");
         T.Assert (False, "Expand did not raise the No_Entity_Type exception");

      exception
         when ADO.Schemas.Entities.No_Entity_Type =>
            null;
      end;
   end Test_Find_Entity_Type_Error;

   --  ------------------------------
   --  Test the Load_Schema operation and check the result schema.
   --  ------------------------------
   procedure Test_Load_Schema (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
   begin
      S.Load_Schema (Schema);

      Table := ADO.Schemas.Find_Table (Schema, "allocate");
      T.Assert (Table /= null, "Table schema for test_allocate not found");

      Assert_Equals (T, "allocate", Get_Name (Table));

      declare
         C : Column_Cursor := Get_Columns (Table);
         Nb_Columns : Integer := 0;
      begin
         while Has_Element (C) loop
            Nb_Columns := Nb_Columns + 1;
            Next (C);
         end loop;
         Assert_Equals (T, 3, Nb_Columns, "Invalid number of columns");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "ID");
      begin
         T.Assert (C /= null, "Cannot find column 'id' in table schema");
         Assert_Equals (T, "id", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_LONG_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
         T.Assert (Is_Primary (C), "Column must be a primary key");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "NAME");
      begin
         T.Assert (C /= null, "Cannot find column 'NAME' in table schema");
         Assert_Equals (T, "name", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_VARCHAR, "Invalid column type");
         T.Assert (Is_Null (C), "Column is null");
         T.Assert (not Is_Primary (C), "Column must not be a primary key");
         Assert_Equals (T, 255, Get_Size (C), "Column has invalid size");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "version");
      begin
         T.Assert (C /= null, "Cannot find column 'version' in table schema");
         Assert_Equals (T, "version", To_Lower_Case (Get_Name (C)), "Invalid column name");
         T.Assert (Get_Type (C) = T_INTEGER, "Invalid column type");
         T.Assert (not Is_Null (C), "Column is null");
      end;

      declare
         C : constant Column_Definition := Find_Column (Table, "this_column_does_not_exist");
      begin
         T.Assert (C = null, "Find_Column must return null for an unknown column");
      end;
   end Test_Load_Schema;

   --  ------------------------------
   --  Test the Table_Cursor operations and check the result schema.
   --  ------------------------------
   procedure Test_Table_Iterator (T : in out Test) is
      S      : constant ADO.Sessions.Session := Regtests.Get_Database;
      Schema : Schema_Definition;
      Table  : Table_Definition;
      Driver : constant String := S.Get_Driver.Get_Driver_Name;
   begin
      S.Load_Schema (Schema);

      declare
         Iter  : Table_Cursor := Schema.Get_Tables;
         Count : Natural := 0;
      begin
         T.Assert (Has_Element (Iter), "The Get_Tables returns an empty iterator");
         while Has_Element (Iter) loop
            Table := Element (Iter);
            T.Assert (Table /= null, "Element function must not return null");
            declare
               Col_Iter : Column_Cursor := Get_Columns (Table);
            begin
               --  T.Assert (Has_Element (Col_Iter), "Table has a column");
               while Has_Element (Col_Iter) loop
                  T.Assert (Element (Col_Iter) /= null, "Element function must not return null");
                  Next (Col_Iter);
               end loop;
            end;
            Count := Count + 1;
            Next (Iter);
         end loop;
         if Driver = "sqlite" then
            Util.Tests.Assert_Equals (T, 21, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "mysql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         elsif Driver = "postgresql" then
            Util.Tests.Assert_Equals (T, 11, Count,
                                      "Invalid number of tables found in the schema");
         end if;
      end;
   end Test_Table_Iterator;

   --  ------------------------------
   --  Test the Table_Cursor operations on an empty schema.
   --  ------------------------------
   procedure Test_Empty_Schema (T : in out Test) is
      Schema : Schema_Definition;
      Iter   : constant Table_Cursor := Schema.Get_Tables;
   begin
      T.Assert (not Has_Element (Iter), "The Get_Tables must return an empty iterator");
      T.Assert (Schema.Find_Table ("test") = null, "The Find_Table must return null");
   end Test_Empty_Schema;

   --  ------------------------------
   --  Test the creation of database.
   --  ------------------------------
   procedure Test_Create_Schema (T : in out Test) is
      use ADO.Sessions.Sources;

      Msg      : Util.Strings.Vectors.Vector;
      Cfg      : Data_Source := Data_Source (Regtests.Get_Controller);
      Driver   : constant String := Cfg.Get_Driver;
      Database : constant String := Cfg.Get_Database;
      Path     : constant String :=
        "db/regtests/" & Cfg.Get_Driver & "/create-ado-" & Driver & ".sql";

      pragma Unreferenced (Msg);
   begin
      if Driver = "sqlite" then
         if Ada.Directories.Exists (Database & ".test") then
            Ada.Directories.Delete_File (Database & ".test");
         end if;
         Cfg.Set_Database (Database & ".test");
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
         T.Assert (Ada.Directories.Exists (Database & ".test"),
                   "The sqlite database was not created");
      else
         ADO.Schemas.Databases.Create_Database (Admin       => Cfg,
                                                Config      => Cfg,
                                                Schema_Path => Path,
                                                Messages    => Msg);
      end if;
   end Test_Create_Schema;

end ADO.Schemas.Tests;

Update the unit test after introduction of a new test database table


-----------------------------------------------------------------------
--  util-encoders -- Encode/Decode streams and strings from one format to another
--  Copyright (C) 2009, 2010, 2011, 2012, 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 Ada.Streams;
with Ada.Finalization;
with Interfaces;

--  === Encoder and Decoders ===
--  The Util.Encoders package defines the Encoder and Decode objects
--  which provide a mechanism to transform a stream from one format into
--  another format.
--
--  ==== Simple encoding and decoding ====
--
package Util.Encoders is

   pragma Preelaborate;

   Not_Supported  : exception;
   Encoding_Error : exception;

   --  Encoder/decoder for Base64 (RFC 4648)
   BASE_64     : constant String := "base64";

   --  Encoder/decoder for Base64 (RFC 4648) using the URL alphabet
   --  (+ and / are replaced by - and _)
   BASE_64_URL : constant String := "base64url";

   --  Encoder/decoder for Base16 (RFC 4648)
   BASE_16     : constant String := "base16";
   HEX         : constant String := "hex";

   --  Encoder for SHA1 (RFC 3174)
   HASH_SHA1   : constant String := "sha1";

   --  ------------------------------
   --  Encoder context object
   --  ------------------------------
   --  The Encoder provides operations to encode and decode
   --  strings or stream of data from one format to another.
   --  The Encoded contains two Transformer
   --  which either encodes or decodes the stream.
   type Encoder is tagged limited private;

   --  Encodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be encoded.
   --  Raises the Not_Supported exception if the encoding is not
   --  supported.
   function Encode (E    : in Encoder;
                    Data : in String) return String;
   function Encode_Binary (E    : in Encoder;
                           Data : in Ada.Streams.Stream_Element_Array) return String;

   --  Create the encoder object for the specified encoding format.
   function Create (Name : in String) return Encoder;

   type Decoder is tagged limited private;

   --  Decodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be decoded.
   --  Raises the Not_Supported exception if the decoding is not
   --  supported.
   function Decode (E    : in Decoder;
                    Data : in String) return String;
   function Decode_Binary (E    : in Decoder;
                           Data : in String) return Ada.Streams.Stream_Element_Array;

   --  Create the decoder object for the specified encoding format.
   function Create (Name : in String) return Decoder;

   --  ------------------------------
   --  Stream Transformation interface
   --  ------------------------------
   --  The Transformer interface defines the operation to transform
   --  a stream from one data format to another.
   type Transformer is limited interface;
   type Transformer_Access is access all Transformer'Class;

   --  Transform the input array represented by Data into
   --  the output array Into.  The transformation made by
   --  the object can be of any nature (Hex encoding, Base64 encoding,
   --  Hex decoding, Base64 decoding, encryption, compression, ...).
   --
   --  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 array.
   --
   --  The transformer returns in Last the last valid position
   --  in the output array Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  array cannot be transformed.
   procedure Transform (E       : in out Transformer;
                        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) is abstract;

   --  Finish encoding the input array.
   procedure Finish (E    : in out Transformer;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset) is null;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in out Transformer'Class;
                       Data : in String) return String;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in out Transformer'Class;
                       Data : in Ada.Streams.Stream_Element_Array) return String;
   function Transform (E    : in out Transformer'Class;
                       Data : in Ada.Streams.Stream_Element_Array)
                       return Ada.Streams.Stream_Element_Array;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer and return the data in
   --  the Into array, setting Last to the last index.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   procedure Transform (E    : in out Transformer'Class;
                        Data : in String;
                        Into : out Ada.Streams.Stream_Element_Array;
                        Last : out Ada.Streams.Stream_Element_Offset);

   --  Encode the value represented by <tt>Val</tt> in the stream array <tt>Into</tt> starting
   --  at position <tt>Pos</tt> in that array.  The value is encoded using LEB128 format, 7-bits
   --  at a time until all non zero bits are written.  The <tt>Last</tt> parameter is updated
   --  to indicate the position of the last valid byte written in <tt>Into</tt>.
   procedure Encode_LEB128 (Into  : in out Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : in Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

   --  Decode from the byte array <tt>From</tt> the value represented as LEB128 format starting
   --  at position <tt>Pos</tt> in that array.  After decoding, the <tt>Last</tt> index is updated
   --  to indicate the last position in the byte array.
   procedure Decode_LEB128 (From  : in Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : out Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

private

   type Encoder is new Ada.Finalization.Limited_Controlled with record
      Encode : Transformer_Access := null;
   end record;

   --  Delete the transformers
   overriding
   procedure Finalize (E : in out Encoder);

   type Decoder is new Ada.Finalization.Limited_Controlled with record
      Decode : Transformer_Access := null;
   end record;

   --  Delete the transformers
   overriding
   procedure Finalize (E : in out Decoder);

end Util.Encoders;

-----------------------------------------------------------------------
--  util-encoders -- Encode/Decode streams and strings from one format to another
--  Copyright (C) 2009, 2010, 2011, 2012, 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 Ada.Streams;
with Ada.Finalization;
with Interfaces;

--  === Encoder and Decoders ===
--  The Util.Encoders package defines the Encoder and Decode objects
--  which provide a mechanism to transform a stream from one format into
--  another format.
--
--  ==== Simple encoding and decoding ====
--
package Util.Encoders is

   pragma Preelaborate;

   Not_Supported  : exception;
   Encoding_Error : exception;

   --  Encoder/decoder for Base64 (RFC 4648)
   BASE_64     : constant String := "base64";

   --  Encoder/decoder for Base64 (RFC 4648) using the URL alphabet
   --  (+ and / are replaced by - and _)
   BASE_64_URL : constant String := "base64url";

   --  Encoder/decoder for Base16 (RFC 4648)
   BASE_16     : constant String := "base16";
   HEX         : constant String := "hex";

   --  Encoder for SHA1 (RFC 3174)
   HASH_SHA1   : constant String := "sha1";

   --  ------------------------------
   --  Encoder context object
   --  ------------------------------
   --  The Encoder provides operations to encode and decode
   --  strings or stream of data from one format to another.
   --  The Encoded contains two Transformer
   --  which either encodes or decodes the stream.
   type Encoder is tagged limited private;

   --  Encodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be encoded.
   --  Raises the Not_Supported exception if the encoding is not
   --  supported.
   function Encode (E    : in Encoder;
                    Data : in String) return String;
   function Encode_Binary (E    : in Encoder;
                           Data : in Ada.Streams.Stream_Element_Array) return String;

   --  Create the encoder object for the specified encoding format.
   function Create (Name : in String) return Encoder;

   type Decoder is tagged limited private;

   --  Decodes the input string Data using the transformation
   --  rules provided by the E encoder.
   --
   --  Returns the encoded string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be decoded.
   --  Raises the Not_Supported exception if the decoding is not
   --  supported.
   function Decode (E    : in Decoder;
                    Data : in String) return String;
   function Decode_Binary (E    : in Decoder;
                           Data : in String) return Ada.Streams.Stream_Element_Array;

   --  Create the decoder object for the specified encoding format.
   function Create (Name : in String) return Decoder;

   --  ------------------------------
   --  Stream Transformation interface
   --  ------------------------------
   --  The Transformer interface defines the operation to transform
   --  a stream from one data format to another.
   type Transformer is limited interface;
   type Transformer_Access is access all Transformer'Class;

   --  Transform the input array represented by Data into
   --  the output array Into.  The transformation made by
   --  the object can be of any nature (Hex encoding, Base64 encoding,
   --  Hex decoding, Base64 decoding, encryption, compression, ...).
   --
   --  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 array.
   --
   --  The transformer returns in Last the last valid position
   --  in the output array Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  array cannot be transformed.
   procedure Transform (E       : in out Transformer;
                        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) is abstract;

   --  Finish encoding the input array.
   procedure Finish (E    : in out Transformer;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset) is null;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in out Transformer'Class;
                       Data : in String) return String;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer.
   --
   --  Returns the transformed string.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   function Transform (E    : in out Transformer'Class;
                       Data : in Ada.Streams.Stream_Element_Array) return String;
   function Transform (E    : in out Transformer'Class;
                       Data : in Ada.Streams.Stream_Element_Array)
                       return Ada.Streams.Stream_Element_Array;

   --  Transform the input string Data using the transformation
   --  rules provided by the E transformer and return the data in
   --  the Into array, setting Last to the last index.
   --
   --  Raises the Encoding_Error exception if the source string
   --  cannot be transformed
   procedure Transform (E    : in out Transformer'Class;
                        Data : in String;
                        Into : out Ada.Streams.Stream_Element_Array;
                        Last : out Ada.Streams.Stream_Element_Offset);

   --  Encode the value represented by <tt>Val</tt> in the stream array <tt>Into</tt> starting
   --  at position <tt>Pos</tt> in that array.  The value is encoded using LEB128 format, 7-bits
   --  at a time until all non zero bits are written.  The <tt>Last</tt> parameter is updated
   --  to indicate the position of the last valid byte written in <tt>Into</tt>.
   procedure Encode_LEB128 (Into  : in out Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : in Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

   --  Decode from the byte array <tt>From</tt> the value represented as LEB128 format starting
   --  at position <tt>Pos</tt> in that array.  After decoding, the <tt>Last</tt> index is updated
   --  to indicate the last position in the byte array.
   procedure Decode_LEB128 (From  : in Ada.Streams.Stream_Element_Array;
                            Pos   : in Ada.Streams.Stream_Element_Offset;
                            Val   : out Interfaces.Unsigned_64;
                            Last  : out Ada.Streams.Stream_Element_Offset);

private

   --  Transform the input data into the target string.
   procedure Convert (E    : in out Transformer'Class;
                      Data : in Ada.Streams.Stream_Element_Array;
                      Into : out String);

   type Encoder is new Ada.Finalization.Limited_Controlled with record
      Encode : Transformer_Access := null;
   end record;

   --  Delete the transformers
   overriding
   procedure Finalize (E : in out Encoder);

   type Decoder is new Ada.Finalization.Limited_Controlled with record
      Decode : Transformer_Access := null;
   end record;

   --  Delete the transformers
   overriding
   procedure Finalize (E : in out Decoder);

end Util.Encoders;

Declare a Convert internal procedure to make a transformation and get the final result in a string passed as parameter. This function is intended to be used for Base16 and Base64 encoding for HMAC/SHA operations where the target string size is well known.


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

with Ada.Task_Attributes;

with Security.Controllers;
package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Permissions.Permission_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Permissions.Controller_Access;
      use type Security.Permissions.Permission_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Permissions.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            --              Result := C.Has_Permission (Context);
            Result := False;
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Permissions.Permission_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

-----------------------------------------------------------------------
--  security-contexts -- Context to provide security information and verify permissions
--  Copyright (C) 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.Task_Attributes;

with Security.Controllers;
package body Security.Contexts is

   package Task_Context is new Ada.Task_Attributes
     (Security_Context_Access, null);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Controller_Access;
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         C : constant Policies.Controller_Access := Context.Manager.Get_Controller (Permission);
      begin
         if C = null then
            Result := False;
         else
            --              Result := C.Has_Permission (Context);
            Result := False;
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is
   begin
      Task_Context.Set_Value (Context.Previous);
   end Finalize;

   --  ------------------------------
   --  Add a context information represented by Value under the name identified by
   --  Name in the security context Context.
   --  ------------------------------
   procedure Add_Context (Context   : in out Security_Context;
                          Name      : in String;
                          Value     : in String) is
   begin
      Context.Context.Include (Key      => Name,
                               New_Item => Value);
   end Add_Context;

   --  ------------------------------
   --  Get the context information registered under the name Name in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  ------------------------------
   function Get_Context (Context  : in Security_Context;
                         Name     : in String) return String is
      Pos : constant Util.Strings.Maps.Cursor := Context.Context.Find (Name);
   begin
      if Util.Strings.Maps.Has_Element (Pos) then
         return Util.Strings.Maps.Element (Pos);
      else
         raise Invalid_Context;
      end if;
   end Get_Context;

   --  ------------------------------
   --  Returns True if a context information was registered under the name Name.
   --  ------------------------------
   function Has_Context (Context : in Security_Context;
                         Name    : in String) return Boolean is
      use type Util.Strings.Maps.Cursor;
   begin
      return Context.Context.Find (Name) /= Util.Strings.Maps.No_Element;
   end Has_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

Use the policy manager

Use the policy manager