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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
with Security.Permissions.Tests;
package body Security.Policies.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Security.Policies");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin

      Caller.Add_Test (Suite, "Test Security.Permissions.Create_Role",
                       Test_Create_Role'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Has_Permission",
                       Test_Has_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Read_Policy (empty)",
                       Test_Read_Empty_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Add_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Get_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Get_Role_Policy",
                       Test_Get_Role_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Read_Policy",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_Roles'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles (invalid)",
                       Test_Set_Invalid_Roles'Access);

      --  These tests are identical but registered under different names
      --  for the test documentation.
      Caller.Add_Test (Suite, "Test Security.Contexts.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Controllers.Roles.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Role_Policy",
                       Test_Role_Policy'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get the roles assigned to the user.
   --  ------------------------------
   function Get_Roles (User : in Test_Principal) return Roles.Role_Map is
   begin
      return User.Roles;
   end Get_Roles;

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Test_Principal) return String is
   begin
      return Util.Strings.To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Test Create_Role and Get_Role_Name
   --  ------------------------------
   procedure Test_Create_Role (T : in out Test) is
      use Security.Policies.Roles;

      M     : Security.Policies.Roles.Role_Policy;
      Role  : Role_Type;
   begin
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      for I in Role + 1 .. Role_Type'Last loop
         declare
            Name : constant String := "admin-" & Role_Type'Image (I);
            Role2 : Role_Type;
         begin
            Role2 := M.Find_Role ("admin");
            T.Assert (Role2 = Role, "Find_Role returned an invalid role");

            M.Create_Role (Name => Name,
                           Role => Role2);
            Assert_Equals (T, Name, M.Get_Role_Name (Role2), "Invalid name");
         end;
      end loop;
   end Test_Create_Role;

   --  ------------------------------
   --  Test Set_Roles
   --  ------------------------------
   procedure Test_Set_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Admin   : Role_Type;
      Manager : Role_Type;
      Map     : Role_Map := (others => False);
   begin
      M.Create_Role (Name => "manager",
                     Role => Manager);
      M.Create_Role (Name => "admin",
                     Role => Admin);
      Assert_Equals (T, "admin", M.Get_Role_Name (Admin), "Invalid name");

      T.Assert (not Map (Admin), "The admin role must not set in the map");
      M.Set_Roles ("admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (not Map (Manager), "The manager role must not be set in the map");

      Map := (others => False);
      M.Set_Roles ("manager,admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (Map (Manager), "The manager role is not set in the map");

   end Test_Set_Roles;

   --  ------------------------------
   --  Test Set_Roles on an invalid role name
   --  ------------------------------
   procedure Test_Set_Invalid_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Map     : Role_Map := (others => False);
   begin
      M.Set_Roles ("manager,admin", Map);
      T.Assert (False, "No exception was raised");

   exception
      when E : Security.Policies.Roles.Invalid_Name =>
         null;
   end Test_Set_Invalid_Roles;

   --  ------------------------------
   --  Test Has_Permission
   --  ------------------------------
   procedure Test_Has_Permission (T : in out Test) is
      M    : Security.Policies.Policy_Manager (1);
--        Perm : Permissions.Permission_Type;
      User : Test_Principal;
   begin
      --        T.Assert (not M.Has_Permission (User, 1), "User has a non-existing permission");
      null;
   end Test_Has_Permission;

   procedure Configure_Policy (Manager : in out Security.Policies.Policy_Manager;
                               Name    : in String) is
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      R           : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
      U           : Security.Policies.URLs.URL_Policy_Access := new URLs.URL_Policy;
   begin
      Manager.Add_Policy (R.all'Access);
      Manager.Add_Policy (U.all'Access);
      Manager.Read_Policy (Util.Files.Compose (Path, Name));
   end Configure_Policy;

   --  ------------------------------
   --  Test the Get_Policy, Get_Role_Policy and Add_Policy operations.
   --  ------------------------------
   procedure Test_Get_Role_Policy (T : in out Test) is
      use type Roles.Role_Policy_Access;

      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P = null, "Get_Policy succeeded");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R = null, "Get_Role_Policy succeeded");

      R := new Roles.Role_Policy;
      M.Add_Policy (R.all'Access);

      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P /= null, "Role policy not found");
      T.Assert (P.all in Roles.Role_Policy'Class, "Invalid role policy");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R /= null, "Get_Role_Policy should not return null");
   end Test_Get_Role_Policy;

   --  ------------------------------
   --  Test reading an empty policy file
   --  ------------------------------
   procedure Test_Read_Empty_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User        : aliased Test_Principal;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      Configure_Policy (M, "empty.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      declare
         Admin : Policies.Roles.Role_Type;
      begin
         Admin := R.Find_Role ("admin");
         T.Fail ("'admin' role was returned");

      exception
         when Security.Policies.Roles.Invalid_Name =>
            null;
      end;

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Admin.Permission),
                "Has_Permission (admin) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Create.Permission),
                "Has_Permission (create) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Update.Permission),
                "Has_Permission (update) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Delete.Permission),
                "Has_Permission (delete) failed for empty policy");

   end Test_Read_Empty_Policy;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      use Security.Permissions.Tests;

      M            : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User         : aliased Test_Principal;
      Admin        : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context      : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      Configure_Policy (M, "simple-policy.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      Admin := R.Find_Role ("admin");

      T.Assert (not Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was granted but user has no role");

      User.Roles (Admin) := True;

      T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was not granted and user has admin role");

      declare

         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
               P   : constant URLs.URI_Permission (URI'Length)
                 := URLs.URI_Permission '(Len => URI'Length, URI => URI);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                         "Permission not granted");
            end;
         end loop;
         Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
      end;
      declare
         use Security.Permissions.Tests;

         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URI : constant String := "/admin/home/list.html";
               P   : constant URLs.URI_Permission (URI'Length)
                 := URLs.URI_Permission '(Len => URI'Length, URI => URI);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                         "Permission not granted");
            end;
         end loop;
         Util.Measures.Report (S, "Has_Permission (1000 calls, cache hit)");
      end;

   end Test_Read_Policy;

   --  ------------------------------
   --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   --  ------------------------------
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (2);
      User        : aliased Test_Principal;
      Admin       : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
      U           : Security.Policies.URLs.URL_Policy_Access;
   begin
      Configure_Policy (M, File);

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      U := Security.Policies.URLs.Get_URL_Policy (M);
      Admin := R.Find_Role (Role);

      declare
         P   : constant URLs.URI_Permission (URI'Length)
           := URLs.URI_Permission '(Len => URI'Length, URI => URI);
      begin
         --  A user without the role should not have the permission.
         T.Assert (not U.Has_Permission (Context    => Context'Unchecked_Access,
                                         Permission => P),
           "Permission was granted for user without role.  URI=" & URI);

         --  Set the role.
         User.Roles (Admin) := True;
         T.Assert (U.Has_Permission (Context    => Context'Unchecked_Access,
                                     Permission => P),
           "Permission was not granted for user with role.  URI=" & URI);
      end;
   end Check_Policy;

   --  ------------------------------
   --  Test reading policy files and using the <role-permission> controller
   --  ------------------------------
   procedure Test_Role_Policy (T : in out Test) is
   begin
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "developer",
                      URI  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/admin/user-should-have-admin-role");
   end Test_Role_Policy;

end Security.Policies.Tests;

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

with Util.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
with Security.Permissions.Tests;
package body Security.Policies.Tests is

   use Util.Tests;

   package Caller is new Util.Test_Caller (Test, "Security.Policies");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin

      Caller.Add_Test (Suite, "Test Security.Permissions.Create_Role",
                       Test_Create_Role'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Has_Permission",
                       Test_Has_Permission'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Read_Policy (empty)",
                       Test_Read_Empty_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Add_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Get_Policy",
                       Test_Get_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Get_Role_Policy",
                       Test_Get_Role_Policy'Access);

      Caller.Add_Test (Suite, "Test Security.Policies.Read_Policy",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_Roles'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles (invalid)",
                       Test_Set_Invalid_Roles'Access);

      --  These tests are identical but registered under different names
      --  for the test documentation.
      Caller.Add_Test (Suite, "Test Security.Contexts.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Controllers.Roles.Has_Permission",
                       Test_Role_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Permissions.Role_Policy",
                       Test_Role_Policy'Access);
   end Add_Tests;

   --  ------------------------------
   --  Get the roles assigned to the user.
   --  ------------------------------
   function Get_Roles (User : in Test_Principal) return Roles.Role_Map is
   begin
      return User.Roles;
   end Get_Roles;

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   function Get_Name (From : in Test_Principal) return String is
   begin
      return Util.Strings.To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Test Create_Role and Get_Role_Name
   --  ------------------------------
   procedure Test_Create_Role (T : in out Test) is
      use Security.Policies.Roles;

      M     : Security.Policies.Roles.Role_Policy;
      Role  : Role_Type;
   begin
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      for I in Role + 1 .. Role_Type'Last loop
         declare
            Name : constant String := "admin-" & Role_Type'Image (I);
            Role2 : Role_Type;
         begin
            Role2 := M.Find_Role ("admin");
            T.Assert (Role2 = Role, "Find_Role returned an invalid role");

            M.Create_Role (Name => Name,
                           Role => Role2);
            Assert_Equals (T, Name, M.Get_Role_Name (Role2), "Invalid name");
         end;
      end loop;
   end Test_Create_Role;

   --  ------------------------------
   --  Test Set_Roles
   --  ------------------------------
   procedure Test_Set_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Admin   : Role_Type;
      Manager : Role_Type;
      Map     : Role_Map := (others => False);
   begin
      M.Create_Role (Name => "manager",
                     Role => Manager);
      M.Create_Role (Name => "admin",
                     Role => Admin);
      Assert_Equals (T, "admin", M.Get_Role_Name (Admin), "Invalid name");

      T.Assert (not Map (Admin), "The admin role must not set in the map");
      M.Set_Roles ("admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (not Map (Manager), "The manager role must not be set in the map");

      Map := (others => False);
      M.Set_Roles ("manager,admin", Map);
      T.Assert (Map (Admin), "The admin role is not set in the map");
      T.Assert (Map (Manager), "The manager role is not set in the map");

   end Test_Set_Roles;

   --  ------------------------------
   --  Test Set_Roles on an invalid role name
   --  ------------------------------
   procedure Test_Set_Invalid_Roles (T : in out Test) is
      use Security.Policies.Roles;

      M       : Security.Policies.Roles.Role_Policy;
      Map     : Role_Map := (others => False);
   begin
      M.Set_Roles ("manager,admin", Map);
      T.Assert (False, "No exception was raised");

   exception
      when E : Security.Policies.Roles.Invalid_Name =>
         null;
   end Test_Set_Invalid_Roles;

   --  ------------------------------
   --  Test Has_Permission
   --  ------------------------------
   procedure Test_Has_Permission (T : in out Test) is
      M    : Security.Policies.Policy_Manager (1);
--        Perm : Permissions.Permission_Type;
      User : Test_Principal;
   begin
      --        T.Assert (not M.Has_Permission (User, 1), "User has a non-existing permission");
      null;
   end Test_Has_Permission;

   procedure Configure_Policy (Manager : in out Security.Policies.Policy_Manager;
                               Name    : in String) is
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      R           : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
      U           : Security.Policies.URLs.URL_Policy_Access := new URLs.URL_Policy;
   begin
      Manager.Add_Policy (R.all'Access);
      Manager.Add_Policy (U.all'Access);
      Manager.Read_Policy (Util.Files.Compose (Path, Name));
   end Configure_Policy;

   --  ------------------------------
   --  Test the Get_Policy, Get_Role_Policy and Add_Policy operations.
   --  ------------------------------
   procedure Test_Get_Role_Policy (T : in out Test) is
      use type Roles.Role_Policy_Access;

      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P = null, "Get_Policy succeeded");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R = null, "Get_Role_Policy succeeded");

      R := new Roles.Role_Policy;
      M.Add_Policy (R.all'Access);

      P := M.Get_Policy (Security.Policies.Roles.NAME);
      T.Assert (P /= null, "Role policy not found");
      T.Assert (P.all in Roles.Role_Policy'Class, "Invalid role policy");

      R := Security.Policies.Roles.Get_Role_Policy (M);
      T.Assert (R /= null, "Get_Role_Policy should not return null");
   end Test_Get_Role_Policy;

   --  ------------------------------
   --  Test reading an empty policy file
   --  ------------------------------
   procedure Test_Read_Empty_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User        : aliased Test_Principal;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
   begin
      Configure_Policy (M, "empty.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      declare
         Admin : Policies.Roles.Role_Type;
      begin
         Admin := R.Find_Role ("admin");
         T.Fail ("'admin' role was returned");

      exception
         when Security.Policies.Roles.Invalid_Name =>
            null;
      end;

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Admin.Permission),
                "Has_Permission (admin) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Create.Permission),
                "Has_Permission (create) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Update.Permission),
                "Has_Permission (update) failed for empty policy");

      T.Assert (not Contexts.Has_Permission (Permissions.Tests.P_Delete.Permission),
                "Has_Permission (delete) failed for empty policy");

   end Test_Read_Empty_Policy;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      use Security.Permissions.Tests;

      M            : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      User         : aliased Test_Principal;
      Admin        : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context      : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      Configure_Policy (M, "simple-policy.xml");
      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      Admin := R.Find_Role ("admin");

      T.Assert (not Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was granted but user has no role");

      User.Roles (Admin) := True;

      T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                "Permission was not granted and user has admin role");

      declare
         S : Util.Measures.Stamp;
         Result : Boolean;
      begin
         for I in 1 .. 1_000 loop
            Result := Contexts.Has_Permission (Permission => P_Admin.Permission);
         end loop;
         Util.Measures.Report (S, "Has_Permission role based (1000 calls)");

         T.Assert (Result, "Permission not granted");
      end;
      declare
         use Security.Permissions.Tests;

         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URI : constant String := "/admin/home/list.html";
               P   : constant URLs.URI_Permission (URI'Length)
                 := URLs.URI_Permission '(Len => URI'Length, URI => URI);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P_Admin.Permission),
                         "Permission not granted");
            end;
         end loop;
         Util.Measures.Report (S, "Has_Permission (1000 calls, cache hit)");
      end;

   end Test_Read_Policy;

   --  ------------------------------
   --  Read the policy file <b>File</b> and perform a test on the given URI
   --  with a user having the given role.
   --  ------------------------------
   procedure Check_Policy (T     : in out Test;
                           File  : in String;
                           Role  : in String;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (2);
      User        : aliased Test_Principal;
      Admin       : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      P           : Security.Policies.Policy_Access;
      R           : Security.Policies.Roles.Role_Policy_Access;
      U           : Security.Policies.URLs.URL_Policy_Access;
   begin
      Configure_Policy (M, File);

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);

      R := Security.Policies.Roles.Get_Role_Policy (M);
      U := Security.Policies.URLs.Get_URL_Policy (M);
      Admin := R.Find_Role (Role);

      declare
         P   : constant URLs.URI_Permission (URI'Length)
           := URLs.URI_Permission '(Len => URI'Length, URI => URI);
      begin
         --  A user without the role should not have the permission.
         T.Assert (not U.Has_Permission (Context    => Context'Unchecked_Access,
                                         Permission => P),
           "Permission was granted for user without role.  URI=" & URI);

         --  Set the role.
         User.Roles (Admin) := True;
         T.Assert (U.Has_Permission (Context    => Context'Unchecked_Access,
                                     Permission => P),
           "Permission was not granted for user with role.  URI=" & URI);
      end;
   end Check_Policy;

   --  ------------------------------
   --  Test reading policy files and using the <role-permission> controller
   --  ------------------------------
   procedure Test_Role_Policy (T : in out Test) is
   begin
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "developer",
                      URI  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URI  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URI  => "/admin/user-should-have-admin-role");
   end Test_Role_Policy;

end Security.Policies.Tests;

Fix benchmark test for Has_Permission

Fix benchmark test for Has_Permission


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

   --  ------------------------------
   --  Get the image link that must be rendered from the wiki image link.
   --  ------------------------------
   overriding
   procedure Make_Image_Link (Renderer : in Default_Link_Renderer;
                              Link     : in Wide_Wide_String;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural) is
      pragma Unreferenced (Renderer);
   begin
      URI    := To_Unbounded_Wide_Wide_String (Link);
      Width  := 0;
      Height := 0;
   end Make_Image_Link;

   --  ------------------------------
   --  Get the page link that must be rendered from the wiki page link.
   --  ------------------------------
   overriding
   procedure Make_Page_Link (Renderer : in Default_Link_Renderer;
                             Link     : in Wide_Wide_String;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean) is
      pragma Unreferenced (Renderer);
   begin
      URI    := To_Unbounded_Wide_Wide_String (Link);
      Exists := True;
   end Make_Page_Link;

   --  ------------------------------
   --  Render the list of nodes from the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document;
                     List   : in Wiki.Nodes.Node_List_Access) is
      use type Wiki.Nodes.Node_List_Access;

      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;

   begin
      if List /= null then
         Wiki.Nodes.Iterate (List, Process'Access);
      end if;
   end Render;

   --  ------------------------------
   --  Render the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document) is
      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;
   begin
      Doc.Iterate (Process'Access);
      Engine.Finish (Doc);
   end Render;

end Wiki.Render;

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

   --  ------------------------------
   --  Get the image link that must be rendered from the wiki image link.
   --  ------------------------------
   overriding
   procedure Make_Image_Link (Renderer : in Default_Link_Renderer;
                              Link     : in Wiki.Strings.WString;
                              URI      : out Wiki.Strings.UString;
                              Width    : out Natural;
                              Height   : out Natural) is
      pragma Unreferenced (Renderer);
   begin
      URI    := Wiki.Strings.To_UString (Link);
      Width  := 0;
      Height := 0;
   end Make_Image_Link;

   --  ------------------------------
   --  Get the page link that must be rendered from the wiki page link.
   --  ------------------------------
   overriding
   procedure Make_Page_Link (Renderer : in Default_Link_Renderer;
                             Link     : in Wiki.Strings.WString;
                             URI      : out Wiki.Strings.UString;
                             Exists   : out Boolean) is
      pragma Unreferenced (Renderer);
   begin
      URI    := Wiki.Strings.To_UString (Link);
      Exists := True;
   end Make_Page_Link;

   --  ------------------------------
   --  Render the list of nodes from the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document;
                     List   : in Wiki.Nodes.Node_List_Access) is
      use type Wiki.Nodes.Node_List_Access;

      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;

   begin
      if List /= null then
         Wiki.Nodes.Iterate (List, Process'Access);
      end if;
   end Render;

   --  ------------------------------
   --  Render the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document) is
      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;
   begin
      Doc.Iterate (Process'Access);
      Engine.Finish (Doc);
   end Render;

end Wiki.Render;

Use the Wiki.Strings.WString and UString types


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

with EL.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is private;
   type Return_Type (<>) is private;
package EL.Methods.Func_1 is

   use Util.Beans.Methods;

   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   function F (Obj : <Bean>; Param : Param1_Type) return Return_Type;
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   function Execute (Method  : in EL.Expressions.Method_Expression'Class;
                     Param   : in Param1_Type;
                     Context : in EL.Contexts.ELContext'Class) return Return_Type;

   --  Function access to the proxy.
   type Proxy_Access is
     access function (O : in Util.Beans.Basic.Readonly_Bean'Class;
                      P : in Param1_Type) return Return_Type;

   --  The binding record which links the method name
   --  to the proxy function.
   type Binding is new Method_Binding with record
      Method : Proxy_Access;
   end record;
   type Binding_Access is access constant Binding;

   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   generic
      --  Name of the method (as exposed in the EL expression)
      Name : String;

      --  The bean type
      type Bean is new Util.Beans.Basic.Readonly_Bean with private;

      --  The bean method to invoke
      with function Method (O  : in Bean;
                            P1 : in Param1_Type) return Return_Type;
   package Bind is

      --  Method that Execute will invoke.
      function Method_Access (O  : in Util.Beans.Basic.Readonly_Bean'Class;
                              P1 : in Param1_Type) return Return_Type;

      F_NAME : aliased constant String := Name;

      --  The proxy binding that can be exposed through
      --  the Method_Bean interface.
      Proxy  : aliased constant Binding
        := Binding '(Name => F_NAME'Access,
                     Method => Method_Access'Access);
   end Bind;

end EL.Methods.Func_1;

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

with EL.Expressions;
with EL.Contexts;
with Util.Beans.Methods;
with Util.Beans.Basic;
generic
   type Param1_Type (<>) is limited private;
   type Return_Type (<>) is private;
package EL.Methods.Func_1 is

   use Util.Beans.Methods;

   --  Execute the method describe by the method expression
   --  and with the given context.  The method signature is:
   --
   --   function F (Obj : <Bean>; Param : Param1_Type) return Return_Type;
   --
   --  where <Bean> inherits from Readonly_Bean
   --  (See Bind package)
   --
   --  Raises Invalid_Method if the method referenced by
   --  the method expression does not exist or does not match
   --  the signature.
   function Execute (Method  : in EL.Expressions.Method_Expression'Class;
                     Param   : in Param1_Type;
                     Context : in EL.Contexts.ELContext'Class) return Return_Type;

   --  Function access to the proxy.
   type Proxy_Access is
     access function (O : in Util.Beans.Basic.Readonly_Bean'Class;
                      P : in Param1_Type) return Return_Type;

   --  The binding record which links the method name
   --  to the proxy function.
   type Binding is new Method_Binding with record
      Method : Proxy_Access;
   end record;
   type Binding_Access is access constant Binding;

   --  Proxy for the binding.
   --  The proxy declares the binding definition that links
   --  the name to the function and it implements the necessary
   --  object conversion to translate the Readonly_Bean
   --  object to the target object type.
   generic
      --  Name of the method (as exposed in the EL expression)
      Name : String;

      --  The bean type
      type Bean is new Util.Beans.Basic.Readonly_Bean with private;

      --  The bean method to invoke
      with function Method (O  : in Bean;
                            P1 : in Param1_Type) return Return_Type;
   package Bind is

      --  Method that Execute will invoke.
      function Method_Access (O  : in Util.Beans.Basic.Readonly_Bean'Class;
                              P1 : in Param1_Type) return Return_Type;

      F_NAME : aliased constant String := Name;

      --  The proxy binding that can be exposed through
      --  the Method_Bean interface.
      Proxy  : aliased constant Binding
        := Binding '(Name => F_NAME'Access,
                     Method => Method_Access'Access);
   end Bind;

end EL.Methods.Func_1;

Change the function parameter to a limited parameter allowing to pass limited types


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

with AWA.Modules.Get;
with Util.Log.Loggers;
package body AWA.Changelogs.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Changelogs.Module");

   --  ------------------------------
   --  Initialize the changelogs module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Changelog_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the changelogs module");

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the changelogs module.
   --  ------------------------------
   function Get_Changelog_Module return Changelog_Module_Access is
      function Get is new AWA.Modules.Get (Changelog_Module, Changelog_Module_Access, NAME);
   begin
      return Get;
   end Get_Changelog_Module;

end AWA.Changelogs.Modules;

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

with Util.Log.Loggers;

with AWA.Modules.Get;
with AWA.Users.Models;
with AWA.Services.Contexts;
with AWA.Changelogs.Models;

with ADO.Sessions;
with ADO.Sessions.Entities;
package body AWA.Changelogs.Modules is

   package ASC renames AWA.Services.Contexts;

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Changelogs.Module");

   --  ------------------------------
   --  Initialize the changelogs module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Changelog_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the changelogs module");

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the changelogs module.
   --  ------------------------------
   function Get_Changelog_Module return Changelog_Module_Access is
      function Get is new AWA.Modules.Get (Changelog_Module, Changelog_Module_Access, NAME);
   begin
      return Get;
   end Get_Changelog_Module;

   --  ------------------------------
   --  Add the log message and associate it with the database entity identified by
   --  the given id and the entity type.  The log message is associated with the current user.
   --  ------------------------------
   procedure Add_Log (Model       : in Changelog_Module;
                      Id          : in ADO.Identifier;
                      Entity_Type : in String;
                      Message     : in String) is
      pragma Unreferenced (Model);

      Ctx     : constant ASC.Service_Context_Access := ASC.Current;
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Kind    : ADO.Entity_Type;
      History : AWA.Changelogs.Models.Changelog_Ref;
   begin
      Ctx.Start;
      Kind := ADO.Sessions.Entities.Find_Entity_Type (DB, Entity_Type);
      History.Set_For_Entity_Id (Id);
      History.Set_User (User);
      History.Set_Date (Ada.Calendar.Clock);
      History.Set_Entity_Type (Kind);
      History.Set_Text (Message);
      History.Save (DB);
      DB.Commit;
   end Add_Log;

end AWA.Changelogs.Modules;

Implement the Add_Log operation

Implement the Add_Log operation


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

with Util.Strings;
with Util.Log.Loggers;
with Util.Http.Clients.Curl.Constants;
package body Util.Http.Clients.Curl is

   use System;

   pragma Linker_Options ("-lcurl");

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Curl");

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access;

   Manager : aliased Curl_Http_Manager;

   --  ------------------------------
   --  Register the CURL Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   --  ------------------------------
   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   --  ------------------------------
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String) is
   begin
      if Code /= CURLE_OK then
         declare
            Error : constant Chars_Ptr := Curl_Easy_Strerror (Code);
            Msg   : constant String := Interfaces.C.Strings.Value (Error);
         begin
            Log.Error ("{0}: {1}", Message, Msg);
            raise Connection_Error with Msg;
         end;
      end if;
   end Check_Code;

   --  ------------------------------
   --  Create a new HTTP request associated with the current request manager.
   --  ------------------------------
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);

      Request : Curl_Http_Request_Access;
      Data    : CURL;
   begin
      Data := Curl_Easy_Init;
      if Data = System.Null_Address then
         raise Storage_Error with "curl_easy_init cannot create the CURL instance";
      end if;
      Request := new Curl_Http_Request;
      Request.Data  := Data;
      Http.Delegate := Request.all'Access;
   end Create;

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access is
   begin
      return Curl_Http_Request'Class (Http.Delegate.all)'Access;
   end Get_Request;

   --  ------------------------------
   --  This function is called by CURL when a response line was read.
   --  ------------------------------
   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T is

      Total : constant Size_T := Size * Nmemb;
      Line  : constant String := Interfaces.C.Strings.Value (Data, Total);
   begin
      Log.Info ("RCV: {0}", Line);
      if Response.Parsing_Body then
         Ada.Strings.Unbounded.Append (Response.Content, Line);

      elsif Total = 2 and then Line (1) = ASCII.CR and then Line (2) = ASCII.LF then
         Response.Parsing_Body := True;

      else
         declare
            Pos   : constant Natural := Util.Strings.Index (Line, ':');
            Start : Natural;
            Last  : Natural;
         begin
            if Pos > 0 then
               Start := Pos + 1;
               while Start <= Line'Last and Line (Start) = ' ' loop
                  Start := Start + 1;
               end loop;
               Last := Line'Last;
               while Last >= Start and (Line (Last) = ASCII.CR or Line (Last) = ASCII.LF) loop
                  Last := Last - 1;
               end loop;
               Response.Add_Header (Name  => Line (Line'First .. Pos - 1),
                                    Value => Line (Start .. Last));
            end if;
         end;
      end if;
      return Total;
   end Read_Response;

   --  ------------------------------
   --  Prepare to setup the headers in the request.
   --  ------------------------------
   procedure Set_Headers (Request : in out Curl_Http_Request) is

      procedure Process (Name, Value : in String) is
         S : Chars_Ptr := Strings.New_String (Name & ": " & Value);
      begin
         Request.Curl_Headers := Curl_Slist_Append (Request.Curl_Headers, S);
         Interfaces.C.Strings.Free (S);
      end Process;

   begin
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;

      Request.Iterate_Headers (Process'Access);
   end Set_Headers;

   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("GET {0}", URI);
      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");

      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HTTPGET, 1);
      Check_Code (Result, "set http GET");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Get;

   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("POST {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Interfaces.C.Strings.Free (Req.Content);
      Req.Content := Strings.New_String (Data);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http POST");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_POSTFIELDS, Req.Content);
      Check_Code (Result, "set post data");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POSTFIELDSIZE, Data'Length);
      Check_Code (Result, "set post data");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Post;

   overriding
   procedure Finalize (Request : in out Curl_Http_Request) is
   begin
      if Request.Data /= System.Null_Address then
         Curl_Easy_Cleanup (Request.Data);
         Request.Data := System.Null_Address;
      end if;
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;
      Interfaces.C.Strings.Free (Request.URL);
      Interfaces.C.Strings.Free (Request.Content);
   end Finalize;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Reply.Content);
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural is
   begin
      return Reply.Status;
   end Get_Status;

end Util.Http.Clients.Curl;

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

with Util.Strings;
with Util.Log.Loggers;
with Util.Http.Clients.Curl.Constants;
package body Util.Http.Clients.Curl is

   use System;

   pragma Linker_Options ("-lcurl");

   Log   : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Curl");

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access;

   PUT_TOKEN : Chars_Ptr := Strings.New_String ("PUT");
   Manager   : aliased Curl_Http_Manager;

   --  ------------------------------
   --  Register the CURL Http manager.
   --  ------------------------------
   procedure Register is
   begin
      Default_Http_Manager := Manager'Access;
   end Register;

   --  ------------------------------
   --  Check the CURL result code and report and exception and a log message if
   --  the CURL code indicates an error.
   --  ------------------------------
   procedure Check_Code (Code    : in CURL_Code;
                         Message : in String) is
   begin
      if Code /= CURLE_OK then
         declare
            Error : constant Chars_Ptr := Curl_Easy_Strerror (Code);
            Msg   : constant String := Interfaces.C.Strings.Value (Error);
         begin
            Log.Error ("{0}: {1}", Message, Msg);
            raise Connection_Error with Msg;
         end;
      end if;
   end Check_Code;

   --  ------------------------------
   --  Create a new HTTP request associated with the current request manager.
   --  ------------------------------
   procedure Create (Manager  : in Curl_Http_Manager;
                     Http     : in out Client'Class) is
      pragma Unreferenced (Manager);

      Request : Curl_Http_Request_Access;
      Data    : CURL;
   begin
      Data := Curl_Easy_Init;
      if Data = System.Null_Address then
         raise Storage_Error with "curl_easy_init cannot create the CURL instance";
      end if;
      Request := new Curl_Http_Request;
      Request.Data  := Data;
      Http.Delegate := Request.all'Access;
   end Create;

   function Get_Request (Http : in Client'Class) return Curl_Http_Request_Access is
   begin
      return Curl_Http_Request'Class (Http.Delegate.all)'Access;
   end Get_Request;

   --  ------------------------------
   --  This function is called by CURL when a response line was read.
   --  ------------------------------
   function Read_Response (Data     : in Chars_Ptr;
                           Size     : in Size_T;
                           Nmemb    : in Size_T;
                           Response : in Curl_Http_Response_Access) return Size_T is

      Total : constant Size_T := Size * Nmemb;
      Line  : constant String := Interfaces.C.Strings.Value (Data, Total);
   begin
      Log.Info ("RCV: {0}", Line);
      if Response.Parsing_Body then
         Ada.Strings.Unbounded.Append (Response.Content, Line);

      elsif Total = 2 and then Line (1) = ASCII.CR and then Line (2) = ASCII.LF then
         Response.Parsing_Body := True;

      else
         declare
            Pos   : constant Natural := Util.Strings.Index (Line, ':');
            Start : Natural;
            Last  : Natural;
         begin
            if Pos > 0 then
               Start := Pos + 1;
               while Start <= Line'Last and Line (Start) = ' ' loop
                  Start := Start + 1;
               end loop;
               Last := Line'Last;
               while Last >= Start and (Line (Last) = ASCII.CR or Line (Last) = ASCII.LF) loop
                  Last := Last - 1;
               end loop;
               Response.Add_Header (Name  => Line (Line'First .. Pos - 1),
                                    Value => Line (Start .. Last));
            end if;
         end;
      end if;
      return Total;
   end Read_Response;

   --  ------------------------------
   --  Prepare to setup the headers in the request.
   --  ------------------------------
   procedure Set_Headers (Request : in out Curl_Http_Request) is

      procedure Process (Name, Value : in String) is
         S : Chars_Ptr := Strings.New_String (Name & ": " & Value);
      begin
         Request.Curl_Headers := Curl_Slist_Append (Request.Curl_Headers, S);
         Interfaces.C.Strings.Free (S);
      end Process;

   begin
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;

      Request.Iterate_Headers (Process'Access);
   end Set_Headers;

   procedure Do_Get (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("GET {0}", URI);
      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");

      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HTTPGET, 1);
      Check_Code (Result, "set http GET");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Get;

   procedure Do_Post (Manager  : in Curl_Http_Manager;
                      Http     : in Client'Class;
                      URI      : in String;
                      Data     : in String;
                      Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("POST {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Interfaces.C.Strings.Free (Req.Content);
      Req.Content := Strings.New_String (Data);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http POST");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_POSTFIELDS, Req.Content);
      Check_Code (Result, "set post data");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POSTFIELDSIZE, Data'Length);
      Check_Code (Result, "set post data");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Post;

   overriding
   procedure Do_Put (Manager  : in Curl_Http_Manager;
                     Http     : in Client'Class;
                     URI      : in String;
                     Data     : in String;
                     Reply    : out Response'Class) is
      pragma Unreferenced (Manager);
      use Interfaces.C;

      Req      : constant Curl_Http_Request_Access := Get_Request (Http);
      Result   : CURL_Code;
      Response : Curl_Http_Response_Access;
      Status   : aliased C.long;
   begin
      Log.Info ("PUT {0}", URI);

      Result := Curl_Easy_Setopt_Write_Callback (Req.Data, Constants.CURLOPT_WRITEUNCTION,
                                                 Read_Response'Access);
      Check_Code (Result, "set callback");
      Req.Set_Headers;

      Interfaces.C.Strings.Free (Req.URL);
      Req.URL := Strings.New_String (URI);

      Interfaces.C.Strings.Free (Req.Content);
      Req.Content := Strings.New_String (Data);

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POST, 1);
      Check_Code (Result, "set http PUT");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_HEADER, 1);
      Check_Code (Result, "set header");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_CUSTOMREQUEST, PUT_TOKEN);
      Check_Code (Result, "set http PUT");

      Result := Curl_Easy_Setopt_Slist (Req.Data, Constants.CURLOPT_HTTPHEADER, Req.Curl_Headers);
      Check_Code (Result, "set http GET headers");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_URL, Req.URL);
      Check_Code (Result, "set url");

      Result := Curl_Easy_Setopt_String (Req.Data, Constants.CURLOPT_POSTFIELDS, Req.Content);
      Check_Code (Result, "set post data");

      Result := Curl_Easy_Setopt_Long (Req.Data, Constants.CURLOPT_POSTFIELDSIZE, Data'Length);
      Check_Code (Result, "set post data");

      Response := new Curl_Http_Response;
      Result := Curl_Easy_Setopt_Data (Req.Data, Constants.CURLOPT_WRITEDATA, Response);
      Check_Code (Result, "set write data");
      Reply.Delegate := Response.all'Access;

      Result := Curl_Easy_Perform (Req.Data);
      Check_Code (Result, "get request");

      Result := Curl_Easy_Getinfo_Long (Req.Data, Constants.CURLINFO_RESPONSE_CODE, Status'Access);
      Check_Code (Result, "get response code");
      Response.Status := Natural (Status);
   end Do_Put;

   overriding
   procedure Finalize (Request : in out Curl_Http_Request) is
   begin
      if Request.Data /= System.Null_Address then
         Curl_Easy_Cleanup (Request.Data);
         Request.Data := System.Null_Address;
      end if;
      if Request.Curl_Headers /= null then
         Curl_Slist_Free_All (Request.Curl_Headers);
         Request.Curl_Headers := null;
      end if;
      Interfaces.C.Strings.Free (Request.URL);
      Interfaces.C.Strings.Free (Request.Content);
   end Finalize;

   --  ------------------------------
   --  Get the response body as a string.
   --  ------------------------------
   overriding
   function Get_Body (Reply : in Curl_Http_Response) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Reply.Content);
   end Get_Body;

   --  ------------------------------
   --  Get the response status code.
   --  ------------------------------
   overriding
   function Get_Status (Reply : in Curl_Http_Response) return Natural is
   begin
      return Reply.Status;
   end Get_Status;

end Util.Http.Clients.Curl;

Implement the Do_Put procedure

Implement the Do_Put procedure