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

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

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

   --  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_Name_Array is
     array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_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 (Role_Type 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);

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

   --  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_Policy is new Policy with record
      Names     : Role_Name_Array (Role_Type'Range) := (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;

Make the Role_Name_Array type public

Make the Role_Name_Array type public


-----------------------------------------------------------------------
--  awa-users-filters -- Specific filters for authentication and key verification
--  Copyright (C) 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 Ada.Strings.Unbounded;

with ASF.Requests;
with ASF.Responses;
with ASF.Sessions;
with ASF.Principals;
with ASF.Filters;
with ASF.Servlets;
with ASF.Security.Filters;

with AWA.Users.Principals;
package AWA.Users.Filters is

   --  Set the user principal on the session associated with the ASF request.
   procedure Set_Session_Principal (Request   : in out ASF.Requests.Request'Class;
                                    Principal : in AWA.Users.Principals.Principal_Access);

   --  ------------------------------
   --  Authentication verification filter
   --  ------------------------------
   --  The Auth_Filter verifies that the user has the permission to access
   --  a given page.  If the user is not logged, it tries to login automatically
   --  by using some persistent cookie.  When this fails, it redirects the
   --  user to a login page (configured by AUTH_FILTER_REDIRECT_PARAM property).
   type Auth_Filter is new ASF.Security.Filters.Auth_Filter with private;

   --  The configuration parameter which controls the redirection page
   --  when the user is not logged (this should be the login page).
   AUTH_FILTER_REDIRECT_PARAM   : constant String := "user.auth-filter.redirect";

   --  A temporary cookie used to store the URL for redirection after the login is successful.
   REDIRECT_COOKIE              : constant String := "RURL";

   --  Initialize the filter and configure the redirection URIs.
   overriding
   procedure Initialize (Filter  : in out Auth_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class);

   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   overriding
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access);

   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   overriding
   procedure Do_Login (Filter   : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  ------------------------------
   --  Verify access key filter
   --  ------------------------------
   --  The Verify_Filter filter verifies an access key associated to a user.
   --  The access key should have been sent to the user by some mechanism (email).
   --  The access key must be valid, that is an Access_Key database entry
   --  must exist and it must be associated with an email address and a user.
   type Verify_Filter is new ASF.Filters.Filter with private;

   --  The request parameter that Verify_Filter will check.
   PARAM_ACCESS_KEY : constant String := "key";

   --  The configuration parameter which controls the redirection page
   --  when the access key is invalid.
   VERIFY_FILTER_REDIRECT_PARAM : constant String := "user.verify-filter.redirect";

   --  Initialize the filter and configure the redirection URIs.
   procedure Initialize (Filter  : in out Verify_Filter;
                         Context : in ASF.Servlets.Servlet_Registry'Class);

   --  Filter a request which contains an access key and verify that the
   --  key is valid and identifies a user.  Once the user is known, create
   --  a session and setup the user principal.
   --
   --  If the access key is missing or invalid, redirect to the
   --  Invalid_Key_URI associated with the filter.
   overriding
   procedure Do_Filter (Filter   : in Verify_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

private

   use Ada.Strings.Unbounded;

   type Auth_Filter is new ASF.Security.Filters.Auth_Filter with record
      Login_URI : Unbounded_String;
   end record;

   type Verify_Filter is new ASF.Filters.Filter with record
      Invalid_Key_URI : Unbounded_String;
   end record;

end AWA.Users.Filters;

-----------------------------------------------------------------------
--  awa-users-filters -- Specific filters for authentication and key verification
--  Copyright (C) 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 Ada.Strings.Unbounded;

with ASF.Requests;
with ASF.Responses;
with ASF.Sessions;
with ASF.Principals;
with ASF.Filters;
with ASF.Servlets;
with ASF.Security.Filters;

with AWA.Users.Principals;
package AWA.Users.Filters is

   --  Set the user principal on the session associated with the ASF request.
   procedure Set_Session_Principal (Request   : in out ASF.Requests.Request'Class;
                                    Principal : in AWA.Users.Principals.Principal_Access);

   --  ------------------------------
   --  Authentication verification filter
   --  ------------------------------
   --  The Auth_Filter verifies that the user has the permission to access
   --  a given page.  If the user is not logged, it tries to login automatically
   --  by using some persistent cookie.  When this fails, it redirects the
   --  user to a login page (configured by AUTH_FILTER_REDIRECT_PARAM property).
   type Auth_Filter is new ASF.Security.Filters.Auth_Filter with private;

   --  The configuration parameter which controls the redirection page
   --  when the user is not logged (this should be the login page).
   AUTH_FILTER_REDIRECT_PARAM   : constant String := "user.auth-filter.redirect";

   --  A temporary cookie used to store the URL for redirection after the login is successful.
   REDIRECT_COOKIE              : constant String := "RURL";

   --  Initialize the filter and configure the redirection URIs.
   overriding
   procedure Initialize (Filter  : in out Auth_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  Authenticate a user by using the auto-login cookie.  This procedure is called if the
   --  current session does not have any principal.  Based on the request and the optional
   --  auto-login cookie passed in Auth_Id, it should identify the user and return
   --  a principal object.  The principal object will be freed when the session is closed.
   --  If the user cannot be authenticated, the returned principal should be null.
   --
   --  The default implementation returns a null principal.
   overriding
   procedure Authenticate (F        : in Auth_Filter;
                           Request  : in out ASF.Requests.Request'Class;
                           Response : in out ASF.Responses.Response'Class;
                           Session  : in ASF.Sessions.Session;
                           Auth_Id  : in String;
                           Principal : out ASF.Principals.Principal_Access);

   --  Display or redirects the user to the login page.  This procedure is called when
   --  the user is not authenticated.
   overriding
   procedure Do_Login (Filter   : in Auth_Filter;
                       Request  : in out ASF.Requests.Request'Class;
                       Response : in out ASF.Responses.Response'Class);

   --  ------------------------------
   --  Verify access key filter
   --  ------------------------------
   --  The Verify_Filter filter verifies an access key associated to a user.
   --  The access key should have been sent to the user by some mechanism (email).
   --  The access key must be valid, that is an Access_Key database entry
   --  must exist and it must be associated with an email address and a user.
   type Verify_Filter is new ASF.Filters.Filter with private;

   --  The request parameter that Verify_Filter will check.
   PARAM_ACCESS_KEY : constant String := "key";

   --  The configuration parameter which controls the redirection page
   --  when the access key is invalid.
   VERIFY_FILTER_REDIRECT_PARAM : constant String := "user.verify-filter.redirect";

   --  Initialize the filter and configure the redirection URIs.
   procedure Initialize (Filter  : in out Verify_Filter;
                         Config  : in ASF.Servlets.Filter_Config);

   --  Filter a request which contains an access key and verify that the
   --  key is valid and identifies a user.  Once the user is known, create
   --  a session and setup the user principal.
   --
   --  If the access key is missing or invalid, redirect to the
   --  Invalid_Key_URI associated with the filter.
   overriding
   procedure Do_Filter (Filter   : in Verify_Filter;
                        Request  : in out ASF.Requests.Request'Class;
                        Response : in out ASF.Responses.Response'Class;
                        Chain    : in out ASF.Servlets.Filter_Chain);

private

   use Ada.Strings.Unbounded;

   type Auth_Filter is new ASF.Security.Filters.Auth_Filter with record
      Login_URI : Unbounded_String;
   end record;

   type Verify_Filter is new ASF.Filters.Filter with record
      Invalid_Key_URI : Unbounded_String;
   end record;

end AWA.Users.Filters;

Update the filter to use the Filter_Config


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

with Util.Tests;
package Util.Dates.Tests is

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

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

   --  Test converting a date in ISO8601.
   procedure Test_ISO8601_Image (T : in out Test);

   --  Test converting a string in ISO8601 into a date.
   procedure Test_ISO8601_Value (T : in out Test);

   --  Test value convertion errors.
   procedure Test_ISO8601_Error (T : in out Test);

end Util.Dates.Tests;

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

with Util.Tests;
package Util.Dates.Tests is

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

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

   --  Test converting a date in ISO8601.
   procedure Test_ISO8601_Image (T : in out Test);

   --  Test converting a string in ISO8601 into a date.
   procedure Test_ISO8601_Value (T : in out Test);

   --  Test value convertion errors.
   procedure Test_ISO8601_Error (T : in out Test);

      --  Test Is_Same_Day operation.
   procedure Test_Is_Same_Day (T : in out Test);

end Util.Dates.Tests;

Add Test_Is_Same_Day to check the Is_Same_Day operation


-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 2010, 2011, 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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

   use type Permissions.Permission_Index;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   procedure Free is
     new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                     Security.Controllers.Controller_Access);

   --  ------------------------------
   --  Default Security Controllers
   --  ------------------------------
   --  The Auth_Controller grants the permission if there is a principal.
   type Auth_Controller is limited new Security.Controllers.Controller with null record;

   --  Returns true if the user associated with the security context Context was
   --  authentified (ie, it has a principal).
   overriding
   function Has_Permission (Handler    : in Auth_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  The Pass_Through_Controller grants access to anybody.
   type Pass_Through_Controller is limited new Security.Controllers.Controller with null record;

   --  Returns true if the user associated with the security context Context has
   --  the permission to access the URL defined in Permission.
   overriding
   function Has_Permission (Handler    : in Pass_Through_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  ------------------------------
   --  Returns true if the user associated with the security context Context was
   --  authentified (ie, it has a principal).
   --  ------------------------------
   overriding
   function Has_Permission (Handler    : in Auth_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      pragma Unreferenced (Handler, Permission);
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         Log.Debug ("Grant permission because a principal exists");
         return True;
      else
         return False;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  the permission to access the URL defined in Permission.
   --  ------------------------------
   overriding
   function Has_Permission (Handler    : in Pass_Through_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      pragma Unreferenced (Handler, Context, Permission);
   begin
      Log.Debug ("Pass through controller grants the permission");
      return True;
   end Has_Permission;

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

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

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;

      --  If the permission has a controller, release it.
      if Manager.Permissions (Index) /= null then
         Log.Warn ("Permission {0} is redefined", Name);

         --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
         --  'missing "with" clause on package "Security.Controllers"'
         --  if we use the 'Security.Controller_Access' type, even if this "with"
         --  clause exist.
         --  gcc 4.4.3 under Ubuntu does not have this issue.
         --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
         --  bug but we have to use a temporary variable and do some type conversion...
         declare
            P : Security.Controllers.Controller_Access := Manager.Permissions (Index).all'Access;
         begin
            Free (P);
         end;
      end if;

      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
   begin
      if Permission.Id >= Manager.Last_Index then
         return False;
      end if;
      declare
         C : constant Controller_Access := Manager.Permissions (Permission.Id);
      begin
         if C = null then
            return False;
         else
            return C.Has_Permission (Context, Permission);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Returns True if the security controller is defined for the given permission index.
   --  ------------------------------
   function Has_Controller (Manager : in Policy_Manager;
                            Index   : in Permissions.Permission_Index) return Boolean is
   begin
      return Index < Manager.Last_Index and then Manager.Permissions (Index) /= null;
   end Has_Controller;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  ------------------------------
   --  Prepare the XML parser to read the policy configuration.
   --  ------------------------------
   procedure Prepare_Config (Manager : in out Policy_Manager;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;
   end Prepare_Config;

   --  ------------------------------
   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   --  ------------------------------
   procedure Finish_Config (Manager : in out Policy_Manager;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;
   end Finish_Config;

   type Policy_Fields is (FIELD_ALL_PERMISSION, FIELD_AUTH_PERMISSION);

   procedure Set_Member (P     : in out Policy_Manager'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (P     : in out Policy_Manager'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
      Name : constant String := Util.Beans.Objects.To_String (Value);
   begin
      case Field is
         when FIELD_ALL_PERMISSION =>
            P.Add_Permission (Name, new Pass_Through_Controller);

         when FIELD_AUTH_PERMISSION =>
            P.Add_Permission (Name, new Auth_Controller);

      end case;
   end Set_Member;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Policy_Manager'Class,
                                               Element_Type_Access => Policy_Manager_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

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

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Manager'Unchecked_Access);
      Manager.Prepare_Config (Reader);

      --  Read the configuration file.
      Reader.Parse (File);

      Manager.Finish_Config (Reader);
   end Read_Policy;

   --  ------------------------------
   --  Initialize the policy manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Policy'Class,
                                        Policy_Access);

   begin
      --  Release the security controllers.
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            if Manager.Permissions (I) /= null then
               --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
               --  'missing "with" clause on package "Security.Controllers"'
               --  if we use the 'Security.Controller_Access' type, even if this "with"
               --  clause exist.
               --  gcc 4.4.3 under Ubuntu does not have this issue.
               --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
               --  bug but we have to use a temporary variable and do some type conversion...
               declare
                  P : Security.Controllers.Controller_Access := Manager.Permissions (I).all'Access;
               begin
                  Free (P);
                  Manager.Permissions (I) := null;
               end;
            end if;
         end loop;
         Free (Manager.Permissions);
      end if;

      --  Release the policy instances.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Free (Manager.Policies (I));
      end loop;

   end Finalize;

begin
   Policy_Mapping.Add_Mapping ("all-permission/name", FIELD_ALL_PERMISSION);
   Policy_Mapping.Add_Mapping ("auth-permission/name", FIELD_AUTH_PERMISSION);
end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  Copyright (C) 2010, 2011, 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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;
with Util.Serialize.Mappers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

   use type Permissions.Permission_Index;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.Policies");

   procedure Free is
     new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                     Security.Controllers.Controller_Access);

   --  ------------------------------
   --  Default Security Controllers
   --  ------------------------------
   --  The Auth_Controller grants the permission if there is a principal.
   type Auth_Controller is limited new Security.Controllers.Controller with null record;

   --  Returns true if the user associated with the security context Context was
   --  authentified (ie, it has a principal).
   overriding
   function Has_Permission (Handler    : in Auth_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  The Pass_Through_Controller grants access to anybody.
   type Pass_Through_Controller is limited new Security.Controllers.Controller with null record;

   --  Returns true if the user associated with the security context Context has
   --  the permission to access the URL defined in Permission.
   overriding
   function Has_Permission (Handler    : in Pass_Through_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean;

   --  ------------------------------
   --  Returns true if the user associated with the security context Context was
   --  authentified (ie, it has a principal).
   --  ------------------------------
   overriding
   function Has_Permission (Handler    : in Auth_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      pragma Unreferenced (Handler, Permission);
      use type Security.Principal_Access;

      P : constant Security.Principal_Access := Context.Get_User_Principal;
   begin
      if P /= null then
         Log.Debug ("Grant permission because a principal exists");
         return True;
      else
         return False;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Returns true if the user associated with the security context Context has
   --  the permission to access the URL defined in Permission.
   --  ------------------------------
   overriding
   function Has_Permission (Handler    : in Pass_Through_Controller;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      pragma Unreferenced (Handler, Context, Permission);
   begin
      Log.Debug ("Pass through controller grants the permission");
      return True;
   end Has_Permission;

   --  ------------------------------
   --  Get the policy index.
   --  ------------------------------
   function Get_Policy_Index (From : in Policy'Class) return Policy_Index is
   begin
      return From.Index;
   end Get_Policy_Index;

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

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Manager : in Policy_Manager;
                        Name    : in String) return Policy_Access is
   begin
      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            return null;
         elsif Manager.Policies (I).Get_Name = Name then
            return Manager.Policies (I);
         end if;
      end loop;
      return null;
   end Get_Policy;

   --  ------------------------------
   --  Add the policy to the policy manager.  After a policy is added in the manager,
   --  it can participate in the security policy.
   --  Raises Policy_Error if the policy table is full.
   --  ------------------------------
   procedure Add_Policy (Manager : in out Policy_Manager;
                         Policy  : in Policy_Access) is
      Name : constant String := Policy.Get_Name;
   begin
      Log.Info ("Adding policy {0}", Name);

      for I in Manager.Policies'Range loop
         if Manager.Policies (I) = null then
            Manager.Policies (I) := Policy;
            Policy.Manager := Manager'Unchecked_Access;
            Policy.Index   := I;
            return;
         end if;
      end loop;
      Log.Error ("Policy table is full, increase policy manager table to {0} to add policy {1}",
                 Policy_Index'Image (Manager.Max_Policies + 1), Name);
      raise Policy_Error;
   end Add_Policy;

   --  ------------------------------
   --  Add a permission under the given permission name and associated with the controller.
   --  To verify the permission, the controller will be called.
   --  ------------------------------
   procedure Add_Permission (Manager    : in out Policy_Manager;
                             Name       : in String;
                             Permission : in Controller_Access) is
      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

      Permissions.Add_Permission (Name, Index);
      if Index >= Manager.Last_Index then
         declare
            Count : constant Permission_Index := Index + 32;
            Perms : constant Controller_Access_Array_Access
              := new Controller_Access_Array (0 .. Count);
         begin
            if Manager.Permissions /= null then
               Perms (Manager.Permissions'Range) := Manager.Permissions.all;
            end if;
            Manager.Permissions := Perms;
            Manager.Last_Index := Count;
         end;
      end if;

      --  If the permission has a controller, release it.
      if Manager.Permissions (Index) /= null then
         Log.Warn ("Permission {0} is redefined", Name);

         --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
         --  'missing "with" clause on package "Security.Controllers"'
         --  if we use the 'Security.Controller_Access' type, even if this "with"
         --  clause exist.
         --  gcc 4.4.3 under Ubuntu does not have this issue.
         --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
         --  bug but we have to use a temporary variable and do some type conversion...
         declare
            P : Security.Controllers.Controller_Access := Manager.Permissions (Index).all'Access;
         begin
            Free (P);
         end;
      end if;

      Manager.Permissions (Index) := Permission;
   end Add_Permission;

   --  ------------------------------
   --  Checks whether the permission defined by the Permission is granted
   --  for the security context passed in Context.
   --  Returns true if such permission is granted.
   --  ------------------------------
   function Has_Permission (Manager    : in Policy_Manager;
                            Context    : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
   begin
      if Permission.Id >= Manager.Last_Index then
         return False;
      end if;
      declare
         C : constant Controller_Access := Manager.Permissions (Permission.Id);
      begin
         if C = null then
            return False;
         else
            return C.Has_Permission (Context, Permission);
         end if;
      end;
   end Has_Permission;

   --  ------------------------------
   --  Returns True if the security controller is defined for the given permission index.
   --  ------------------------------
   function Has_Controller (Manager : in Policy_Manager;
                            Index   : in Permissions.Permission_Index) return Boolean is
   begin
      return Index < Manager.Last_Index and then Manager.Permissions (Index) /= null;
   end Has_Controller;

   --  ------------------------------
   --  Create the policy contexts to be associated with the security context.
   --  ------------------------------
   function Create_Policy_Contexts (Manager : in Policy_Manager)
                                    return Policy_Context_Array_Access is
   begin
      return new Policy_Context_Array (1 .. Manager.Max_Policies);
   end Create_Policy_Contexts;

   --  ------------------------------
   --  Prepare the XML parser to read the policy configuration.
   --  ------------------------------
   procedure Prepare_Config (Manager : in out Policy_Manager;
                             Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;
   end Prepare_Config;

   --  ------------------------------
   --  Finish reading the XML policy configuration.  The security policy implementation can use
   --  this procedure to perform any configuration setup after the configuration is parsed.
   --  ------------------------------
   procedure Finish_Config (Manager : in out Policy_Manager;
                            Reader  : in out Util.Serialize.IO.XML.Parser) is
   begin
      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;
   end Finish_Config;

   type Policy_Fields is (FIELD_GRANT_PERMISSION, FIELD_AUTH_PERMISSION);

   procedure Set_Member (P     : in out Policy_Manager'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (P     : in out Policy_Manager'Class;
                         Field : in Policy_Fields;
                         Value : in Util.Beans.Objects.Object) is
      Name : constant String := Util.Beans.Objects.To_String (Value);
   begin
      case Field is
         when FIELD_GRANT_PERMISSION =>
            P.Add_Permission (Name, new Pass_Through_Controller);

         when FIELD_AUTH_PERMISSION =>
            P.Add_Permission (Name, new Auth_Controller);

      end case;
   end Set_Member;

   package Policy_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Policy_Manager'Class,
                                               Element_Type_Access => Policy_Manager_Access,
                                               Fields              => Policy_Fields,
                                               Set_Member          => Set_Member);

   Policy_Mapping        : aliased Policy_Mapper.Mapper;

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

      use Util;

      Reader : Util.Serialize.IO.XML.Parser;

      package Policy_Config is
        new Reader_Config (Reader, Manager'Unchecked_Access);
      pragma Warnings (Off, Policy_Config);
   begin
      Log.Info ("Reading policy file {0}", File);

      Reader.Add_Mapping ("policy-rules", Policy_Mapping'Access);
      Policy_Mapper.Set_Context (Reader, Manager'Unchecked_Access);
      Manager.Prepare_Config (Reader);

      --  Read the configuration file.
      Reader.Parse (File);

      Manager.Finish_Config (Reader);
   end Read_Policy;

   --  ------------------------------
   --  Initialize the policy manager.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Policy_Manager) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);
      procedure Free is
        new Ada.Unchecked_Deallocation (Policy'Class,
                                        Policy_Access);

   begin
      --  Release the security controllers.
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            if Manager.Permissions (I) /= null then
               --  SCz 2011-12-03: GNAT 2011 reports a compilation error:
               --  'missing "with" clause on package "Security.Controllers"'
               --  if we use the 'Security.Controller_Access' type, even if this "with"
               --  clause exist.
               --  gcc 4.4.3 under Ubuntu does not have this issue.
               --  We use the 'Security.Controllers.Controller_Access' type to avoid the compiler
               --  bug but we have to use a temporary variable and do some type conversion...
               declare
                  P : Security.Controllers.Controller_Access := Manager.Permissions (I).all'Access;
               begin
                  Free (P);
                  Manager.Permissions (I) := null;
               end;
            end if;
         end loop;
         Free (Manager.Permissions);
      end if;

      --  Release the policy instances.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Free (Manager.Policies (I));
      end loop;

   end Finalize;

begin
   Policy_Mapping.Add_Mapping ("grant-permission/name", FIELD_GRANT_PERMISSION);
   Policy_Mapping.Add_Mapping ("auth-permission/name", FIELD_AUTH_PERMISSION);
end Security.Policies;

Rename the <all-permission> into <grant-permission>


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

with ASF.Components.Base;
with ASF.Views.Nodes;
with ASF.Views.Nodes.Jsf;
with ASF.Components.Html.Selects;
with ASF.Components.Core.Views;
package body ASF.Components.Core.Factory is

   function Create_View return Base.UIComponent_Access;
   function Create_ViewAction return Base.UIComponent_Access;
   function Create_ViewMetaData return Base.UIComponent_Access;
   function Create_ViewParameter return Base.UIComponent_Access;
   function Create_Parameter return Base.UIComponent_Access;
   function Create_SelectItem return Base.UIComponent_Access;
   function Create_SelectItems return Base.UIComponent_Access;

   --  ------------------------------
   --  Create an UIView component
   --  ------------------------------
   function Create_View return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIView;
   end Create_View;

   --  ------------------------------
   --  Create an UIViewAction component
   --  ------------------------------
   function Create_ViewAction return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIViewAction;
   end Create_ViewAction;

   --  ------------------------------
   --  Create an UIViewMetaData component
   --  ------------------------------
   function Create_ViewMetaData return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIViewMetaData;
   end Create_ViewMetaData;

   --  ------------------------------
   --  Create an UIViewParameter component
   --  ------------------------------
   function Create_ViewParameter return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIViewParameter;
   end Create_ViewParameter;

   --  ------------------------------
   --  Create an UIParameter component
   --  ------------------------------
   function Create_Parameter return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.UIParameter;
   end Create_Parameter;

   --  ------------------------------
   --  Create an UISelectItem component
   --  ------------------------------
   function Create_SelectItem return Base.UIComponent_Access is
   begin
      return new ASF.Components.Html.Selects.UISelectItem;
   end Create_SelectItem;

   --  ------------------------------
   --  Create an UISelectItems component
   --  ------------------------------
   function Create_SelectItems return Base.UIComponent_Access is
   begin
      return new ASF.Components.Html.Selects.UISelectItems;
   end Create_SelectItems;

   use ASF.Views.Nodes;

   URI                     : aliased constant String := "http://java.sun.com/jsf/core";
   ATTRIBUTE_TAG           : aliased constant String := "attribute";
   CONVERT_DATE_TIME_TAG   : aliased constant String := "convertDateTime";
   CONVERTER_TAG           : aliased constant String := "converter";
   FACET_TAG               : aliased constant String := "facet";
   METADATA_TAG            : aliased constant String := "metadata";
   PARAM_TAG               : aliased constant String := "param";
   SELECT_ITEM_TAG         : aliased constant String := "selectItem";
   SELECT_ITEMS_TAG        : aliased constant String := "selectItems";
   VALIDATE_LENGTH_TAG     : aliased constant String := "validateLength";
   VALIDATE_LONG_RANGE_TAG : aliased constant String := "validateLongRange";
   VALIDATOR_TAG           : aliased constant String := "validator";
   VIEW_TAG                : aliased constant String := "view";
   VIEW_ACTION_TAG         : aliased constant String := "viewAction";
   VIEW_PARAM_TAG          : aliased constant String := "viewParam";

   Core_Bindings : aliased constant ASF.Factory.Binding_Array
     := (1 => (Name      => ATTRIBUTE_TAG'Access,
               Component => null,
               Tag       => ASF.Views.Nodes.Jsf.Create_Attribute_Tag_Node'Access),

         2 => (Name      => CONVERT_DATE_TIME_TAG'Access,
               Component => null,
               Tag       => ASF.Views.Nodes.Jsf.Create_Convert_Date_Time_Tag_Node'Access),

         3 => (Name      => CONVERTER_TAG'Access,
               Component => null,
               Tag       => ASF.Views.Nodes.Jsf.Create_Converter_Tag_Node'Access),

         4 => (Name      => FACET_TAG'Access,
               Component => null,
               Tag       => ASF.Views.Nodes.Jsf.Create_Facet_Tag_Node'Access),

         5 => (Name      => METADATA_TAG'Access,
               Component => Create_ViewMetaData'Access,
               Tag       => ASF.Views.Nodes.Jsf.Create_Metadata_Tag_Node'Access),

         6 => (Name      => PARAM_TAG'Access,
               Component => Create_Parameter'Access,
               Tag       => Create_Component_Node'Access),

         7 => (Name      => SELECT_ITEM_TAG'Access,
               Component => Create_SelectItem'Access,
               Tag       => Create_Component_Node'Access),

         8 => (Name      => SELECT_ITEMS_TAG'Access,
               Component => Create_SelectItems'Access,
               Tag       => Create_Component_Node'Access),

         9 => (Name      => VALIDATE_LENGTH_TAG'Access,
               Component => null,
               Tag       => ASF.Views.Nodes.Jsf.Create_Length_Validator_Tag_Node'Access),

        10 => (Name      => VALIDATE_LONG_RANGE_TAG'Access,
               Component => null,
               Tag       => ASF.Views.Nodes.Jsf.Create_Range_Validator_Tag_Node'Access),

        11 => (Name      => VALIDATOR_TAG'Access,
               Component => null,
               Tag       => ASF.Views.Nodes.Jsf.Create_Validator_Tag_Node'Access),

        12 => (Name      => VIEW_TAG'Access,
               Component => Create_View'Access,
               Tag       => Create_Component_Node'Access),

        13 => (Name      => VIEW_ACTION_TAG'Access,
                Component => Create_ViewAction'Access,
                Tag       => Create_Component_Node'Access),

        14 => (Name      => VIEW_PARAM_TAG'Access,
               Component => Create_ViewParameter'Access,
               Tag       => Create_Component_Node'Access)
        );

   Core_Factory : aliased constant ASF.Factory.Factory_Bindings
     := (URI => URI'Access, Bindings => Core_Bindings'Access);

   --  ------------------------------
   --  Get the HTML component factory.
   --  ------------------------------
   function Definition return ASF.Factory.Factory_Bindings_Access is
   begin
      return Core_Factory'Access;
   end Definition;

end ASF.Components.Core.Factory;

-----------------------------------------------------------------------
--  core-factory -- Factory for Core UI Components
--  Copyright (C) 2009, 2010, 2011, 2012, 2014, 2018 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.Components.Base;
with ASF.Views.Nodes;
with ASF.Views.Nodes.Jsf;
with ASF.Components.Html.Selects;
with ASF.Components.Core.Views;
package body ASF.Components.Core.Factory is

   function Create_View return Base.UIComponent_Access;
   function Create_ViewAction return Base.UIComponent_Access;
   function Create_ViewMetaData return Base.UIComponent_Access;
   function Create_ViewParameter return Base.UIComponent_Access;
   function Create_Parameter return Base.UIComponent_Access;
   function Create_SelectItem return Base.UIComponent_Access;
   function Create_SelectItems return Base.UIComponent_Access;

   --  ------------------------------
   --  Create an UIView component
   --  ------------------------------
   function Create_View return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIView;
   end Create_View;

   --  ------------------------------
   --  Create an UIViewAction component
   --  ------------------------------
   function Create_ViewAction return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIViewAction;
   end Create_ViewAction;

   --  ------------------------------
   --  Create an UIViewMetaData component
   --  ------------------------------
   function Create_ViewMetaData return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIViewMetaData;
   end Create_ViewMetaData;

   --  ------------------------------
   --  Create an UIViewParameter component
   --  ------------------------------
   function Create_ViewParameter return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.Views.UIViewParameter;
   end Create_ViewParameter;

   --  ------------------------------
   --  Create an UIParameter component
   --  ------------------------------
   function Create_Parameter return Base.UIComponent_Access is
   begin
      return new ASF.Components.Core.UIParameter;
   end Create_Parameter;

   --  ------------------------------
   --  Create an UISelectItem component
   --  ------------------------------
   function Create_SelectItem return Base.UIComponent_Access is
   begin
      return new ASF.Components.Html.Selects.UISelectItem;
   end Create_SelectItem;

   --  ------------------------------
   --  Create an UISelectItems component
   --  ------------------------------
   function Create_SelectItems return Base.UIComponent_Access is
   begin
      return new ASF.Components.Html.Selects.UISelectItems;
   end Create_SelectItems;

   use ASF.Views.Nodes;

   URI                     : aliased constant String := "http://java.sun.com/jsf/core";
   ATTRIBUTE_TAG           : aliased constant String := "attribute";
   CONVERT_DATE_TIME_TAG   : aliased constant String := "convertDateTime";
   CONVERTER_TAG           : aliased constant String := "converter";
   FACET_TAG               : aliased constant String := "facet";
   METADATA_TAG            : aliased constant String := "metadata";
   PARAM_TAG               : aliased constant String := "param";
   SELECT_ITEM_TAG         : aliased constant String := "selectItem";
   SELECT_ITEMS_TAG        : aliased constant String := "selectItems";
   VALIDATE_LENGTH_TAG     : aliased constant String := "validateLength";
   VALIDATE_LONG_RANGE_TAG : aliased constant String := "validateLongRange";
   VALIDATOR_TAG           : aliased constant String := "validator";
   VIEW_TAG                : aliased constant String := "view";
   VIEW_ACTION_TAG         : aliased constant String := "viewAction";
   VIEW_PARAM_TAG          : aliased constant String := "viewParam";

   --  ------------------------------
   --  Get the HTML component factory.
   --  ------------------------------
   procedure Register (Factory : in out ASF.Factory.Component_Factory) is
   begin
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => ATTRIBUTE_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Attribute_Tag_Node'Access,
                            Create => null);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => CONVERT_DATE_TIME_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Convert_Date_Time_Tag_Node'Access,
                            Create => null);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => CONVERTER_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Converter_Tag_Node'Access,
                            Create => null);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => FACET_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Facet_Tag_Node'Access,
                            Create => null);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => METADATA_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Metadata_Tag_Node'Access,
                            Create => Create_ViewMetaData'Access);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => PARAM_TAG'Access,
                            Tag    => Create_Component_Node'Access,
                            Create => Create_Parameter'Access);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => SELECT_ITEM_TAG'Access,
                            Tag    => Create_Component_Node'Access,
                            Create => Create_SelectItem'Access);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => SELECT_ITEMS_TAG'Access,
                            Tag    => Create_Component_Node'Access,
                            Create => Create_SelectItems'Access);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => VALIDATE_LENGTH_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Length_Validator_Tag_Node'Access,
                            Create => null);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => VALIDATE_LONG_RANGE_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Range_Validator_Tag_Node'Access,
                            Create => null);

      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => VALIDATOR_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Validator_Tag_Node'Access,
                            Create => null);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => VIEW_TAG'Access,
                            Tag    => ASF.Views.Nodes.Jsf.Create_Validator_Tag_Node'Access,
                            Create => null);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => VIEW_TAG'Access,
                            Tag    => Create_Component_Node'Access,
                            Create => Create_View'Access);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => VIEW_ACTION_TAG'Access,
                            Tag    => Create_Component_Node'Access,
                            Create => Create_ViewAction'Access);
      ASF.Factory.Register (Factory,
                            URI    => URI'Access,
                            Name   => VIEW_PARAM_TAG'Access,
                            Tag    => Create_Component_Node'Access,
                            Create => Create_ViewParameter'Access);
   end Register;

end ASF.Components.Core.Factory;

Change the Definition function into a Register procedure