-----------------------------------------------------------------------
--  applications -- Ada Web Application
--  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 Util.Beans.Basic;
with Util.Locales;

with EL.Objects;
with EL.Contexts;
with EL.Functions;
with EL.Functions.Default;
with EL.Variables.Default;
with Ada.Strings.Unbounded;

with ASF.Locales;
with ASF.Factory;
with ASF.Converters;
with ASF.Validators;
with ASF.Contexts.Faces;
with ASF.Contexts.Exceptions;
with ASF.Lifecycles;
with ASF.Applications.Views;
with ASF.Navigations;
with ASF.Beans;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with ASF.Events.Faces.Actions;
with Security.Permissions;  use Security;

package ASF.Applications.Main is

   use ASF.Beans;

   --  ------------------------------
   --  Factory for creation of lifecycle, view handler
   --  ------------------------------
   type Application_Factory is tagged limited private;

   --  Create the lifecycle handler.  The lifecycle handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Lifecycles.Default.Default_Lifecycle object.
   --  It can be overriden to change the behavior of the ASF request lifecycle.
   function Create_Lifecycle_Handler (App : in Application_Factory)
                                      return ASF.Lifecycles.Lifecycle_Access;

   --  Create the view handler.  The view handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Applications.Views.View_Handler object.
   --  It can be overriden to change the views associated with the application.
   function Create_View_Handler (App : in Application_Factory)
                                 return ASF.Applications.Views.View_Handler_Access;

   --  Create the navigation handler.  The navigation handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Navigations.Navigation_Handler object.
   --  It can be overriden to change the navigations associated with the application.
   function Create_Navigation_Handler (App : in Application_Factory)
                                       return ASF.Navigations.Navigation_Handler_Access;

   --  Create the permission manager.  The permission manager is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a Security.Permissions.Permission_Manager object.
   function Create_Permission_Manager (App : in Application_Factory)
                                       return Security.Permissions.Permission_Manager_Access;

   --  Create the exception handler.  The exception handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a ASF.Contexts.Exceptions.Exception_Handler object.
   function Create_Exception_Handler (App : in Application_Factory)
                                      return ASF.Contexts.Exceptions.Exception_Handler_Access;

   --  ------------------------------
   --  Application
   --  ------------------------------
   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with private;
   type Application_Access is access all Application'Class;

   --  Get the application view handler.
   function Get_View_Handler (App : access Application)
                              return access Views.View_Handler'Class;

   --  Get the lifecycle handler.
   function Get_Lifecycle_Handler (App : in Application)
                                   return ASF.Lifecycles.Lifecycle_Access;

   --  Get the navigation handler.
   function Get_Navigation_Handler (App : in Application)
                                    return ASF.Navigations.Navigation_Handler_Access;

   --  Get the permission manager associated with this application.
   function Get_Permission_Manager (App : in Application)
                                    return Security.Permissions.Permission_Manager_Access;

   --  Get the action event listener responsible for processing action
   --  events and triggering the navigation to the next view using the
   --  navigation handler.
   function Get_Action_Listener (App : in Application)
                                 return ASF.Events.Faces.Actions.Action_Listener_Access;

   --  Process the action associated with the action event.  The action returns
   --  and outcome which is then passed to the navigation handler to navigate to
   --  the next view.
   overriding
   procedure Process_Action (Listener : in Application;
                             Event    : in ASF.Events.Faces.Actions.Action_Event'Class;
                             Context  : in out Contexts.Faces.Faces_Context'Class);

   --  Initialize the application
   procedure Initialize (App     : in out Application;
                         Conf    : in Config;
                         Factory : in out Application_Factory'Class);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   procedure Initialize_Components (App : in out Application);

   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out Config);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   procedure Initialize_Filters (App : in out Application);

   --  Finalizes the application, freeing the memory.
   overriding
   procedure Finalize (App : in out Application);

   --  Get the configuration parameter;
   function Get_Config (App   : Application;
                        Param : Config_Param) return String;

   --  Set a global variable in the global EL contexts.
   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in String);

   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in EL.Objects.Object);

   --  Resolve a global variable and return its value.
   --  Raises the EL.Functions.No_Variable exception if the variable does not exist.
   function Get_Global (App : in Application;
                        Name : in Ada.Strings.Unbounded.Unbounded_String;
                        Context : in EL.Contexts.ELContext'Class)
                        return EL.Objects.Object;

   --  Get the list of supported locales for this application.
   function Get_Supported_Locales (App : in Application)
                                   return Util.Locales.Locale_Array;

   --  Add the locale to the list of supported locales.
   procedure Add_Supported_Locale (App    : in out Application;
                                   Locale : in Util.Locales.Locale);

   --  Get the default locale defined by the application.
   function Get_Default_Locale (App : in Application) return Util.Locales.Locale;

   --  Set the default locale defined by the application.
   procedure Set_Default_Locale (App    : in out Application;
                                 Locale : in Util.Locales.Locale);

   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   function Calculate_Locale (Handler : in Application;
                              Context : in ASF.Contexts.Faces.Faces_Context'Class)
                              return Util.Locales.Locale;

   --  Register a bundle and bind it to a facelet variable.
   procedure Register (App    : in out Application;
                       Name   : in String;
                       Bundle : in String);

   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   procedure Register (App     : in out Application;
                       Name    : in String;
                       Class   : in String;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE);

   --  Register under the name identified by Name the class instance Class.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Class   : in ASF.Beans.Class_Binding_Access);

   --  Register under the name identified by Name a function to create a bean.
   --  This is a simplified class registration.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Handler : in ASF.Beans.Create_Bean_Access);

   --  Create a bean by using the create operation registered for the name
   procedure Create (App     : in Application;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Context : in EL.Contexts.ELContext'Class;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access;
                     Scope   : out Scope_Type);

   --  Add a converter in the application.  The converter is referenced by
   --  the specified name in the XHTML files.
   procedure Add_Converter (App       : in out Application;
                            Name      : in String;
                            Converter : in ASF.Converters.Converter_Access);

   --  Register a binding library in the factory.
   procedure Add_Components (App      : in out Application;
                             Bindings : in ASF.Factory.Factory_Bindings_Access);

   --  Closes the application
   procedure Close (App : in out Application);

   --  Set the current faces context before processing a view.
   procedure Set_Context (App     : in out Application;
                          Context : in ASF.Contexts.Faces.Faces_Context_Access);

   --  Execute the lifecycle phases on the faces context.
   procedure Execute_Lifecycle (App     : in Application;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Dispatch the request received on a page.
   procedure Dispatch (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Dispatch a bean action request.
   --  1. Find the bean object identified by Name, create it if necessary.
   --  2. Resolve the bean method identified by Operation.
   --  3. If the method is an action method (see ASF.Events.Actions), call that method.
   --  4. Using the outcome action result, decide using the navigation handler what
   --     is the result view.
   --  5. Render the result view resolved by the navigation handler.
   procedure Dispatch (App       : in out Application;
                       Name      : in String;
                       Operation : in String;
                       Request   : in out ASF.Requests.Request'Class;
                       Response  : in out ASF.Responses.Response'Class;
                       Prepare   : access procedure (Bean : access Util.Beans.Basic.Bean'Class));

   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   function Find (App  : in Application;
                  Name : in EL.Objects.Object) return ASF.Converters.Converter_Access;

   --  Find the validator instance that was registered under the given name.
   --  Returns null if no such validator exist.
   function Find_Validator (App  : in Application;
                            Name : in EL.Objects.Object)
                            return ASF.Validators.Validator_Access;

   --  Register some functions
   generic
      with procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);
   procedure Register_Functions (App : in out Application'Class);

   --  Register some bean definitions.
   generic
      with procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory);
   procedure Register_Beans (App : in out Application'Class);

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (App    : in out Application;
                          Name   : in String;
                          Locale : in String;
                          Bundle : out ASF.Locales.Bundle);

private

   type Application_Factory is tagged limited null record;

   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with record
      View    : aliased ASF.Applications.Views.View_Handler;
      Lifecycle : ASF.Lifecycles.Lifecycle_Access;
      Factory : aliased ASF.Beans.Bean_Factory;
      Locales : ASF.Locales.Factory;
      Globals : aliased EL.Variables.Default.Default_Variable_Mapper;

      Functions : aliased EL.Functions.Default.Default_Function_Mapper;

      --  The component factory
      Components : aliased ASF.Factory.Component_Factory;

      --  The action listener.
      Action_Listener : ASF.Events.Faces.Actions.Action_Listener_Access;

      --  The navigation handler.
      Navigation      : ASF.Navigations.Navigation_Handler_Access := null;

      --  The permission manager.
      Permissions     : Security.Permissions.Permission_Manager_Access := null;

   end record;

end ASF.Applications.Main;

-----------------------------------------------------------------------
--  applications -- Ada Web Application
--  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 Util.Beans.Basic;
with Util.Locales;

with EL.Objects;
with EL.Contexts;
with EL.Functions;
with EL.Functions.Default;
with EL.Variables.Default;
with Ada.Strings.Unbounded;

with ASF.Locales;
with ASF.Factory;
with ASF.Converters;
with ASF.Validators;
with ASF.Contexts.Faces;
with ASF.Contexts.Exceptions;
with ASF.Lifecycles;
with ASF.Applications.Views;
with ASF.Navigations;
with ASF.Beans;
with ASF.Requests;
with ASF.Responses;
with ASF.Servlets;
with ASF.Events.Faces.Actions;
with Security.Policies;  use Security;

package ASF.Applications.Main is

   use ASF.Beans;

   --  ------------------------------
   --  Factory for creation of lifecycle, view handler
   --  ------------------------------
   type Application_Factory is tagged limited private;

   --  Create the lifecycle handler.  The lifecycle handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Lifecycles.Default.Default_Lifecycle object.
   --  It can be overriden to change the behavior of the ASF request lifecycle.
   function Create_Lifecycle_Handler (App : in Application_Factory)
                                      return ASF.Lifecycles.Lifecycle_Access;

   --  Create the view handler.  The view handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Applications.Views.View_Handler object.
   --  It can be overriden to change the views associated with the application.
   function Create_View_Handler (App : in Application_Factory)
                                 return ASF.Applications.Views.View_Handler_Access;

   --  Create the navigation handler.  The navigation handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates an ASF.Navigations.Navigation_Handler object.
   --  It can be overriden to change the navigations associated with the application.
   function Create_Navigation_Handler (App : in Application_Factory)
                                       return ASF.Navigations.Navigation_Handler_Access;

   --  Create the security policy manager.  The security policy manager is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a Security.Policies.Policy_Manager object.
   function Create_Security_Manager (App : in Application_Factory)
                                       return Security.Policies.Policy_Manager_Access;

   --  Create the exception handler.  The exception handler is created during
   --  the initialization phase of the application.  The default implementation
   --  creates a ASF.Contexts.Exceptions.Exception_Handler object.
   function Create_Exception_Handler (App : in Application_Factory)
                                      return ASF.Contexts.Exceptions.Exception_Handler_Access;

   --  ------------------------------
   --  Application
   --  ------------------------------
   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with private;
   type Application_Access is access all Application'Class;

   --  Get the application view handler.
   function Get_View_Handler (App : access Application)
                              return access Views.View_Handler'Class;

   --  Get the lifecycle handler.
   function Get_Lifecycle_Handler (App : in Application)
                                   return ASF.Lifecycles.Lifecycle_Access;

   --  Get the navigation handler.
   function Get_Navigation_Handler (App : in Application)
                                    return ASF.Navigations.Navigation_Handler_Access;

   --  Get the permission manager associated with this application.
   function Get_Security_Manager (App : in Application)
                                    return Security.Policies.Policy_Manager_Access;

   --  Get the action event listener responsible for processing action
   --  events and triggering the navigation to the next view using the
   --  navigation handler.
   function Get_Action_Listener (App : in Application)
                                 return ASF.Events.Faces.Actions.Action_Listener_Access;

   --  Process the action associated with the action event.  The action returns
   --  and outcome which is then passed to the navigation handler to navigate to
   --  the next view.
   overriding
   procedure Process_Action (Listener : in Application;
                             Event    : in ASF.Events.Faces.Actions.Action_Event'Class;
                             Context  : in out Contexts.Faces.Faces_Context'Class);

   --  Initialize the application
   procedure Initialize (App     : in out Application;
                         Conf    : in Config;
                         Factory : in out Application_Factory'Class);

   --  Initialize the ASF components provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the component factories used by the application.
   procedure Initialize_Components (App : in out Application);

   --  Initialize the application configuration properties.  Properties defined in Conf
   --  are expanded by using the EL expression resolver.
   procedure Initialize_Config (App  : in out Application;
                                Conf : in out Config);

   --  Initialize the servlets provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application servlets.
   procedure Initialize_Servlets (App : in out Application);

   --  Initialize the filters provided by the application.
   --  This procedure is called by Initialize.
   --  It should register the application filters.
   procedure Initialize_Filters (App : in out Application);

   --  Finalizes the application, freeing the memory.
   overriding
   procedure Finalize (App : in out Application);

   --  Get the configuration parameter;
   function Get_Config (App   : Application;
                        Param : Config_Param) return String;

   --  Set a global variable in the global EL contexts.
   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in String);

   procedure Set_Global (App     : in out Application;
                         Name    : in String;
                         Value   : in EL.Objects.Object);

   --  Resolve a global variable and return its value.
   --  Raises the EL.Functions.No_Variable exception if the variable does not exist.
   function Get_Global (App : in Application;
                        Name : in Ada.Strings.Unbounded.Unbounded_String;
                        Context : in EL.Contexts.ELContext'Class)
                        return EL.Objects.Object;

   --  Get the list of supported locales for this application.
   function Get_Supported_Locales (App : in Application)
                                   return Util.Locales.Locale_Array;

   --  Add the locale to the list of supported locales.
   procedure Add_Supported_Locale (App    : in out Application;
                                   Locale : in Util.Locales.Locale);

   --  Get the default locale defined by the application.
   function Get_Default_Locale (App : in Application) return Util.Locales.Locale;

   --  Set the default locale defined by the application.
   procedure Set_Default_Locale (App    : in out Application;
                                 Locale : in Util.Locales.Locale);

   --  Compute the locale that must be used according to the Accept-Language request
   --  header and the application supported locales.
   function Calculate_Locale (Handler : in Application;
                              Context : in ASF.Contexts.Faces.Faces_Context'Class)
                              return Util.Locales.Locale;

   --  Register a bundle and bind it to a facelet variable.
   procedure Register (App    : in out Application;
                       Name   : in String;
                       Bundle : in String);

   --  Register the bean identified by Name and associated with the class Class.
   --  The class must have been registered by using the Register class operation.
   --  The scope defines the scope of the bean.
   procedure Register (App     : in out Application;
                       Name    : in String;
                       Class   : in String;
                       Params  : in Parameter_Bean_Ref.Ref;
                       Scope   : in Scope_Type := REQUEST_SCOPE);

   --  Register under the name identified by Name the class instance Class.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Class   : in ASF.Beans.Class_Binding_Access);

   --  Register under the name identified by Name a function to create a bean.
   --  This is a simplified class registration.
   procedure Register_Class (App     : in out Application;
                             Name    : in String;
                             Handler : in ASF.Beans.Create_Bean_Access);

   --  Create a bean by using the create operation registered for the name
   procedure Create (App     : in Application;
                     Name    : in Ada.Strings.Unbounded.Unbounded_String;
                     Context : in EL.Contexts.ELContext'Class;
                     Result  : out Util.Beans.Basic.Readonly_Bean_Access;
                     Scope   : out Scope_Type);

   --  Add a converter in the application.  The converter is referenced by
   --  the specified name in the XHTML files.
   procedure Add_Converter (App       : in out Application;
                            Name      : in String;
                            Converter : in ASF.Converters.Converter_Access);

   --  Register a binding library in the factory.
   procedure Add_Components (App      : in out Application;
                             Bindings : in ASF.Factory.Factory_Bindings_Access);

   --  Closes the application
   procedure Close (App : in out Application);

   --  Set the current faces context before processing a view.
   procedure Set_Context (App     : in out Application;
                          Context : in ASF.Contexts.Faces.Faces_Context_Access);

   --  Execute the lifecycle phases on the faces context.
   procedure Execute_Lifecycle (App     : in Application;
                                Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  Dispatch the request received on a page.
   procedure Dispatch (App      : in out Application;
                       Page     : in String;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  Dispatch a bean action request.
   --  1. Find the bean object identified by Name, create it if necessary.
   --  2. Resolve the bean method identified by Operation.
   --  3. If the method is an action method (see ASF.Events.Actions), call that method.
   --  4. Using the outcome action result, decide using the navigation handler what
   --     is the result view.
   --  5. Render the result view resolved by the navigation handler.
   procedure Dispatch (App       : in out Application;
                       Name      : in String;
                       Operation : in String;
                       Request   : in out ASF.Requests.Request'Class;
                       Response  : in out ASF.Responses.Response'Class;
                       Prepare   : access procedure (Bean : access Util.Beans.Basic.Bean'Class));

   --  Find the converter instance that was registered under the given name.
   --  Returns null if no such converter exist.
   function Find (App  : in Application;
                  Name : in EL.Objects.Object) return ASF.Converters.Converter_Access;

   --  Find the validator instance that was registered under the given name.
   --  Returns null if no such validator exist.
   function Find_Validator (App  : in Application;
                            Name : in EL.Objects.Object)
                            return ASF.Validators.Validator_Access;

   --  Register some functions
   generic
      with procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);
   procedure Register_Functions (App : in out Application'Class);

   --  Register some bean definitions.
   generic
      with procedure Set_Beans (Factory : in out ASF.Beans.Bean_Factory);
   procedure Register_Beans (App : in out Application'Class);

   --  Load the resource bundle identified by the Name and for the given
   --  Locale.
   procedure Load_Bundle (App    : in out Application;
                          Name   : in String;
                          Locale : in String;
                          Bundle : out ASF.Locales.Bundle);

private

   type Application_Factory is tagged limited null record;

   type Application is new ASF.Servlets.Servlet_Registry
     and ASF.Events.Faces.Actions.Action_Listener with record
      View    : aliased ASF.Applications.Views.View_Handler;
      Lifecycle : ASF.Lifecycles.Lifecycle_Access;
      Factory : aliased ASF.Beans.Bean_Factory;
      Locales : ASF.Locales.Factory;
      Globals : aliased EL.Variables.Default.Default_Variable_Mapper;

      Functions : aliased EL.Functions.Default.Default_Function_Mapper;

      --  The component factory
      Components : aliased ASF.Factory.Component_Factory;

      --  The action listener.
      Action_Listener : ASF.Events.Faces.Actions.Action_Listener_Access;

      --  The navigation handler.
      Navigation      : ASF.Navigations.Navigation_Handler_Access := null;

      --  The permission manager.
      Permissions     : Security.Policies.Policy_Manager_Access := null;

   end record;

end ASF.Applications.Main;

Rename Permission_Manager into Security_Manager


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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <policy-rules>
--      <security-role>
--        <role-name>admin</role-name>
--      </security-role>
--      <security-role>
--        <role-name>manager</role-name>
--      </security-role>
--      <role-permission>
--        <name>create-workspace</name>
--        <role>admin</role>
--        <role>manager</role>
--      </role-permission>
--      ...
--    </policy-rules>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   type Role_Name_Array is array (Positive range <>) of Ada.Strings.Unbounded.String_Access;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Get the number of roles set in the map.
   function Get_Count (Map : in Role_Map) return Natural;

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

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

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Get the roles that grant the given permission.
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map;

   --  Get the list of role names that are defined by the role map.
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   --  Array to map a permission index to a list of roles that are granted the permission.
   type Permission_Role_Array is array (Permission_Index) of Role_Map;

   type Role_Map_Name_Array is array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_Map_Name_Array := (others => null);
      Next_Role : Role_Type := Role_Type'First;
      Name      : Util.Beans.Objects.Object;
      Roles     : Role_Type_Array (1 .. Integer (Role_Type'Last)) := (others => 0);
      Count     : Natural := 0;

      --  The Grants array indicates for each permission the list of roles
      --  that are granted the permission.  This array allows a O(1) lookup.
      --  The implementation is limited to 256 permissions and 64 roles so this array uses 2K.
      --  The default is that no role is assigned to the permission.
      Grants    : Permission_Role_Array := (others => (others => False));
   end record;

end Security.Policies.Roles;

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

with Ada.Strings.Unbounded;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <policy-rules>
--      <security-role>
--        <role-name>admin</role-name>
--      </security-role>
--      <security-role>
--        <role-name>manager</role-name>
--      </security-role>
--      <role-permission>
--        <name>create-workspace</name>
--        <role>admin</role>
--        <role>manager</role>
--      </role-permission>
--      ...
--    </policy-rules>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   type Role_Name_Array is array (Positive range <>) of Ada.Strings.Unbounded.String_Access;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Get the number of roles set in the map.
   function Get_Count (Map : in Role_Map) return Natural;

   --  Return the list of role names separated by ','.
   function To_String (List : in Role_Name_Array) return String;

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

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

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Get the roles that grant the given permission.
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map;

   --  Get the list of role names that are defined by the role map.
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   --  Array to map a permission index to a list of roles that are granted the permission.
   type Permission_Role_Array is array (Permission_Index) of Role_Map;

   type Role_Map_Name_Array is array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_Map_Name_Array := (others => null);
      Next_Role : Role_Type := Role_Type'First;
      Name      : Util.Beans.Objects.Object;
      Roles     : Role_Type_Array (1 .. Integer (Role_Type'Last)) := (others => 0);
      Count     : Natural := 0;

      --  The Grants array indicates for each permission the list of roles
      --  that are granted the permission.  This array allows a O(1) lookup.
      --  The implementation is limited to 256 permissions and 64 roles so this array uses 2K.
      --  The default is that no role is assigned to the permission.
      Grants    : Permission_Role_Array := (others => (others => False));
   end record;

end Security.Policies.Roles;

Declare the To_String function to convert a Role_Map into a printable string


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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Util.Beans.Basic;
package Util.Beans.Objects.Maps is

   package Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Object,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   subtype Cursor is Maps.Cursor;
   subtype Map is Maps.Map;

   --  Make all the Maps operations available (a kind of 'use Maps' for anybody).
   function Length (Container : in Map) return Ada.Containers.Count_Type renames Maps.Length;
   function Is_Empty (Container : in Map) return Boolean renames Maps.Is_Empty;
   procedure Clear (Container : in out Map) renames Maps.Clear;
   function Key (Position : Cursor) return String renames Maps.Key;

   procedure Include (Container : in out Map;
                      Key : in String;
                      New_Item : in Object) renames Maps.Include;
   procedure Query_Element (Position : in Cursor;
                            Process  : not null access procedure (Key     : String;
                                                                  Element : Object))
                            renames Maps.Query_Element;

   function Has_Element (Position : Cursor) return Boolean renames Maps.Has_Element;
   function Element (Position : Cursor) return Object renames Maps.Element;
   procedure Next (Position : in out Cursor) renames Maps.Next;
   function Next (Position : Cursor) return Cursor renames Maps.Next;
   function Equivalent_Keys (Left, Right : Cursor) return Boolean renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : Cursor; Right : String) return Boolean
                             renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : String; Right : Cursor) return Boolean
                             renames Maps.Equivalent_Keys;
   function Copy (Source : Maps.Map; Capacity : in Ada.Containers.Count_Type) return Maps.Map
     renames Maps.Copy;

   --  ------------------------------
   --  Map Bean
   --  ------------------------------
   --  The Map_Bean is a map of objects that also exposes the Bean interface.
   --  This allows the map to be available and accessed from an Object instance.
   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with private;
   type Map_Bean_Access is access all Map_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : in Map_Bean;
                       Name : in String) return Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   procedure Set_Value (From  : in out Map_Bean;
                        Name  : in String;
                        Value : in Object);

   --  Create an object that contains a <tt>Map_Bean</tt> instance.
   function Create return Object;

private

   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with null record;

end Util.Beans.Objects.Maps;

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

with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Util.Beans.Basic;
package Util.Beans.Objects.Maps is

   package Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Object,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   subtype Cursor is Maps.Cursor;
   subtype Map is Maps.Map;

   --  Make all the Maps operations available (a kind of 'use Maps' for anybody).
   function Length (Container : in Map) return Ada.Containers.Count_Type renames Maps.Length;
   function Is_Empty (Container : in Map) return Boolean renames Maps.Is_Empty;
   procedure Clear (Container : in out Map) renames Maps.Clear;
   function Key (Position : Cursor) return String renames Maps.Key;

   procedure Include (Container : in out Map;
                      Key : in String;
                      New_Item : in Object) renames Maps.Include;
   procedure Query_Element (Position : in Cursor;
                            Process  : not null access procedure (Key     : String;
                                                                  Element : Object))
                            renames Maps.Query_Element;

   function Has_Element (Position : Cursor) return Boolean renames Maps.Has_Element;
   function Element (Position : Cursor) return Object renames Maps.Element;
   procedure Next (Position : in out Cursor) renames Maps.Next;
   function Next (Position : Cursor) return Cursor renames Maps.Next;
   function Equivalent_Keys (Left, Right : Cursor) return Boolean renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : Cursor; Right : String) return Boolean
                             renames Maps.Equivalent_Keys;
   function Equivalent_Keys (Left : String; Right : Cursor) return Boolean
                             renames Maps.Equivalent_Keys;
   function Copy (Source : Maps.Map; Capacity : in Ada.Containers.Count_Type) return Maps.Map
     renames Maps.Copy;

   --  ------------------------------
   --  Map Bean
   --  ------------------------------
   --  The Map_Bean is a map of objects that also exposes the Bean interface.
   --  This allows the map to be available and accessed from an Object instance.
   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with private;
   type Map_Bean_Access is access all Map_Bean'Class;

   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   function Get_Value (From : in Map_Bean;
                       Name : in String) return Object;

   --  Set the value identified by the name.
   --  If the map contains the given name, the value changed.
   --  Otherwise name is added to the map and the value associated with it.
   procedure Set_Value (From  : in out Map_Bean;
                        Name  : in String;
                        Value : in Object);

   --  Create an object that contains a <tt>Map_Bean</tt> instance.
   function Create return Object;

   --  Iterate over the members of the map.
   procedure Iterate (From    : in Object;
                      Process : not null access procedure (Name : in String;
                                                           Item : in Object));

private

   type Map_Bean is new Maps.Map and Util.Beans.Basic.Bean with null record;

end Util.Beans.Objects.Maps;

Declare Iterate procedure

Declare Iterate procedure


-----------------------------------------------------------------------
--  babel-base-users-tests - Unit tests for babel users
--  Copyright (C) 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 Util.Tests;

package Babel.Base.Users.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test the Find function resolving some existing user.
   procedure Test_Find (T : in out Test);

   --  Test the Get_Name operation.
   procedure Test_Get_Name (T : in out Test);

   --  Test the Get_Uid operation.
   procedure Test_Get_Uid (T : in out Test);

end Babel.Base.Users.Tests;

-----------------------------------------------------------------------
--  babel-base-users-tests - Unit tests for babel users
--  Copyright (C) 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 Util.Tests;

package Babel.Base.Users.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new Util.Tests.Test with null record;

   --  Test the Find function resolving some existing user.
   procedure Test_Find (T : in out Test);

   --  Test the Get_Name operation.
   procedure Test_Get_Name (T : in out Test);

   --  Test the Get_Uid operation.
   procedure Test_Get_Uid (T : in out Test);

   --  Test the Get_Group operation.
   procedure Test_Get_Group (T : in out Test);

end Babel.Base.Users.Tests;

Declare the Test_Get_Group procedure

Declare the Test_Get_Group procedure


-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 2012, 2013 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 ADO.Queries;
with ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with Util.Beans.Lists.Strings;

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : constant ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Question (From, Id);
            From.Tags.Load_Tags (DB, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Service.Load_Answer (From, From.Question,
                                   ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : Natural;
   begin
      if Name = "tags" then
         Pos := From.Questions.Get_Row_Index;
         if Pos = 0 then
            return Util.Beans.Objects.Null_Object;
         end if;
         declare
            Item : constant Models.Question_Info := From.Questions.List.Element (Pos - 1);
         begin
            return From.Tags.Get_Tags (Item.Id);
         end;
      elsif Name = "questions" then
         return Util.Beans.Objects.To_Object (Value   => From.Questions_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      else
         return From.Questions.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
         From.Load_List;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Into.Questions, Session, Query);
      declare
         List : ADO.Utils.Identifier_Vector;
         Iter : Question_Info_Vectors.Cursor := Into.Questions.List.First;
      begin
         while Question_Info_Vectors.Has_Element (Iter) loop
            List.Append (Question_Info_Vectors.Element (Iter).Id);
            Question_Info_Vectors.Next (Iter);
         end loop;
         Into.Tags.Load_Tags (Session, AWA.Questions.Models.QUESTION_TABLE.Table.all,
                              List);
      end;
   end Load_List;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
--        Session : ADO.Sessions.Session := Module.Get_Session;
--        Query   : ADO.Queries.Context;
   begin
      Object.Service := Module;
      Object.Questions_Bean := Object.Questions'Unchecked_Access;
--        Query.Set_Query (AWA.Questions.Models.Query_Question_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "entity_type",
--                                          Table   => AWA.Questions.Models.QUESTION_TABLE,
--                                          Session => Session);
--        AWA.Questions.Models.List (Object.Questions, Session, Query);
      Object.Load_List;
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
            Id      : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.ANSWER_TABLE,
                                              Session => Session);

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            AWA.Questions.Models.List (From.Answer_List, Session, Query);

            --  Load the tags if any.
            From.Tags.Load_Tags (Session, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

-----------------------------------------------------------------------
--  awa-questions-beans -- Beans for module questions
--  Copyright (C) 2012, 2013 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 ADO.Queries;
with ADO.Utils;
with ADO.Sessions;
with ADO.Sessions.Entities;

with Util.Beans.Lists.Strings;

with AWA.Tags.Modules;
with AWA.Services.Contexts;
package body AWA.Questions.Beans is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "tags" then
         return Util.Beans.Objects.To_Object (From.Tags_Bean, Util.Beans.Objects.STATIC);
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Question_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "title" then
         From.Set_Title (Util.Beans.Objects.To_String (Value));

      elsif Name = "description" then
         From.Set_Description (Util.Beans.Objects.To_String (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Ctx : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
            DB  : constant ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Service.Load_Question (From, Id);
            From.Tags.Load_Tags (DB, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the question.
   --  ------------------------------
   procedure Save (Bean    : in out Question_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Question (Bean);
      Bean.Tags.Update_Tags (Bean.Get_Id);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Question_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Question (Bean);
   end Delete;

   --  ------------------------------
   --  Create the Question_Bean bean instance.
   --  ------------------------------
   function Create_Question_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
      return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Question_Bean_Access := new Question_Bean;
   begin
      Object.Service   := Module;
      Object.Tags_Bean := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      Object.Tags.Set_Permission ("question-edit");
      return Object.all'Access;
   end Create_Question_Bean;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Answer_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "question_id" then
         return Util.Beans.Objects.To_Object (Long_Long_Integer (From.Question.Get_Id));
      elsif From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Questions.Models.Answer_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Answer_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         From.Service.Load_Answer (From, From.Question,
                                   ADO.Utils.To_Identifier (Value));

      elsif Name = "answer" then
         From.Set_Answer (Util.Beans.Objects.To_String (Value));

      elsif Name = "question_id" and not Util.Beans.Objects.Is_Null (Value) then
         From.Service.Load_Question (From.Question,
                                     ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create or save the answer.
   --  ------------------------------
   procedure Save (Bean    : in out Answer_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Save_Answer (Question => Bean.Question,
                                Answer   => Bean);
   end Save;

   --  ------------------------------
   --  Delete the question.
   --  ------------------------------
   procedure Delete (Bean    : in out Answer_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Service.Delete_Answer (Answer => Bean);
   end Delete;

   --  ------------------------------
   --  Create the answer bean instance.
   --  ------------------------------
   function Create_Answer_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access is
      Object : constant Answer_Bean_Access := new Answer_Bean;
   begin
      Object.Service := Module;
      return Object.all'Access;
   end Create_Answer_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_List_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
      Pos : Natural;
   begin
      if Name = "tags" then
         Pos := From.Questions.Get_Row_Index;
         if Pos = 0 then
            return Util.Beans.Objects.Null_Object;
         end if;
         declare
            Item : constant Models.Question_Info := From.Questions.List.Element (Pos - 1);
         begin
            return From.Tags.Get_Tags (Item.Id);
         end;
      elsif Name = "questions" then
         return Util.Beans.Objects.To_Object (Value   => From.Questions_Bean,
                                              Storage => Util.Beans.Objects.STATIC);
      elsif Name = "tag" then
         return Util.Beans.Objects.To_Object (From.Tag);
      else
         return From.Questions.Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "tag" then
         From.Tag := Util.Beans.Objects.To_Unbounded_String (Value);
         From.Load_List;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Load the list of question.  If a tag was set, filter the list of questions with the tag.
   --  ------------------------------
   procedure Load_List (Into : in out Question_List_Bean) is
      use AWA.Questions.Models;
      use AWA.Services;
      use type ADO.Identifier;

      Session : ADO.Sessions.Session := Into.Service.Get_Session;
      Query   : ADO.Queries.Context;
      Tag_Id  : ADO.Identifier;
   begin
      AWA.Tags.Modules.Find_Tag_Id (Session, Ada.Strings.Unbounded.To_String (Into.Tag), Tag_Id);
      if Tag_Id /= ADO.NO_IDENTIFIER then
         Query.Set_Query (AWA.Questions.Models.Query_Question_Tag_List);
         Query.Bind_Param (Name => "tag", Value => Tag_Id);
      else
         Query.Set_Query (AWA.Questions.Models.Query_Question_List);
      end if;
      ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                        Name    => "entity_type",
                                        Table   => AWA.Questions.Models.QUESTION_TABLE,
                                        Session => Session);
      AWA.Questions.Models.List (Into.Questions, Session, Query);
      declare
         List : ADO.Utils.Identifier_Vector;
         Iter : Question_Info_Vectors.Cursor := Into.Questions.List.First;
      begin
         while Question_Info_Vectors.Has_Element (Iter) loop
            List.Append (Question_Info_Vectors.Element (Iter).Id);
            Question_Info_Vectors.Next (Iter);
         end loop;
         Into.Tags.Load_Tags (Session, AWA.Questions.Models.QUESTION_TABLE.Table.all,
                              List);
      end;
   end Load_List;

   --  ------------------------------
   --  Create the Question_Info_List_Bean bean instance.
   --  ------------------------------
   function Create_Question_List_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      use AWA.Questions.Models;
      use AWA.Services;

      Object  : constant Question_List_Bean_Access := new Question_List_Bean;
--        Session : ADO.Sessions.Session := Module.Get_Session;
--        Query   : ADO.Queries.Context;
   begin
      Object.Service := Module;
      Object.Questions_Bean := Object.Questions'Unchecked_Access;
--        Query.Set_Query (AWA.Questions.Models.Query_Question_List);
--        ADO.Sessions.Entities.Bind_Param (Params  => Query,
--                                          Name    => "entity_type",
--                                          Table   => AWA.Questions.Models.QUESTION_TABLE,
--                                          Session => Session);
--        AWA.Questions.Models.List (Object.Questions, Session, Query);
      Object.Load_List;
      return Object.all'Access;
   end Create_Question_List_Bean;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Question_Display_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if Name = "answers" then
         return Util.Beans.Objects.To_Object (Value   => From.Answer_List_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "question" then
         return Util.Beans.Objects.To_Object (Value   => From.Question_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      elsif Name = "tags" then
         return Util.Beans.Objects.To_Object (Value   => From.Tags_Bean,
                                              Storage => Util.Beans.Objects.STATIC);

      else
         return Util.Beans.Objects.Null_Object;
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Question_Display_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            package ASC renames AWA.Services.Contexts;
            use AWA.Questions.Models;
            use AWA.Services;

            Session : ADO.Sessions.Session := From.Service.Get_Session;
            Query   : ADO.Queries.Context;
            List    : AWA.Questions.Models.Question_Display_Info_List_Bean;
            Ctx     : constant ASC.Service_Context_Access := ASC.Current;
            Id      : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            Query.Set_Query (AWA.Questions.Models.Query_Question_Info);
            Query.Bind_Param ("question_id", Id);
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.QUESTION_TABLE,
                                              Session => Session);
            AWA.Questions.Models.List (List, Session, Query);
            if not List.List.Is_Empty then
               From.Question := List.List.Element (0);
            end if;
            Query.Clear;
            Query.Bind_Param ("question_id", Util.Beans.Objects.To_Integer (Value));
            Query.Bind_Param ("user_id", Ctx.Get_User_Identifier);
            ADO.Sessions.Entities.Bind_Param (Params  => Query,
                                              Name    => "entity_type",
                                              Table   => AWA.Questions.Models.ANSWER_TABLE,
                                              Session => Session);

            Query.Set_Query (AWA.Questions.Models.Query_Answer_List);
            AWA.Questions.Models.List (From.Answer_List, Session, Query);

            --  Load the tags if any.
            From.Tags.Load_Tags (Session, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the Question_Display_Bean bean instance.
   --  ------------------------------
   function Create_Question_Display_Bean (Module : in AWA.Questions.Modules.Question_Module_Access)
                                       return Util.Beans.Basic.Readonly_Bean_Access is
      Object  : constant Question_Display_Bean_Access := new Question_Display_Bean;
   begin
      Object.Service          := Module;
      Object.Question_Bean    := Object.Question'Access;
      Object.Answer_List_Bean := Object.Answer_List'Access;
      Object.Tags_Bean        := Object.Tags'Access;
      Object.Tags.Set_Entity_Type (AWA.Questions.Models.QUESTION_TABLE);
      return Object.all'Access;
   end Create_Question_Display_Bean;

end AWA.Questions.Beans;

Make the current tag value visible to the question list bean