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

with Util.Log;
with Util.Log.Loggers;
with ADO.Sessions;
with ADO.Model;
with ADO.Objects;

package body ADO.Sequences.Hilo is

   use Util.Log;
   use ADO.Sessions;
   use Sequence_Maps;
   use ADO.Model;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Sequences.Hilo");

   type HiLoGenerator_Access is access all HiLoGenerator'Class;

   --  ------------------------------
   --  Create a high low sequence generator
   --  ------------------------------
   function Create_HiLo_Generator
     (Sess_Factory : access ADO.Sessions.Factory.Session_Factory'Class)
      return Generator_Access is
      Result : constant HiLoGenerator_Access := new HiLoGenerator;
   begin
      Result.Factory := Sess_Factory;
      return Result.all'Access;
   end Create_HiLo_Generator;

   --  ------------------------------
   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   --  ------------------------------
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : out Identifier) is
   begin
      --  Get a new sequence range
      if Gen.Next_Id >= Gen.Last_Id then
         Allocate_Sequence (Gen);
      end if;

      Id := Gen.Next_Id;
      Gen.Next_Id := Gen.Next_Id + 1;
   end Allocate;

   --  ------------------------------
   --  Allocate a new sequence block.
   --  ------------------------------
   procedure Allocate_Sequence (Gen : in out HiLoGenerator) is
      Name      : constant String := Get_Sequence_Name (Gen);
      Value     : Identifier;
      Seq_Block : Sequence_Ref;
      DB        : Master_Session'Class := Gen.Get_Session;
   begin
      loop
         --  Allocate a new sequence within a transaction.
         declare
            Params : Parameter_List;
            Found  : Boolean;
         begin
            Log.Info ("Allocate sequence range for {0}", Name);

            DB.Begin_Transaction;
            Params.Set_Filter ("name = ?");
            Params.Bind_Param (Position => 1, Value => Name);
            Seq_Block.Find (Database => DB, Parameters => Params, Found => Found);

            begin
               if Found then
                  Value := Seq_Block.Get_Value;
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               else
                  Value := 1;
                  Seq_Block.Set_Name (Name);
                  Seq_Block.Set_Block_Size (Gen.Block_Size);
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               end if;
               DB.Commit;

               Gen.Next_Id := Value;
               Gen.Last_Id := Seq_Block.Get_Value;
               return;

            exception
               when ADO.Objects.LAZY_LOCK =>
                  Log.Info ("Sequence table modified, retrying");
                  DB.Rollback;
            end;

         exception
            when E : others =>
               Log.Error ("Cannot allocate sequence range", E);
               raise;
         end;
      end loop;
   end Allocate_Sequence;

end ADO.Sequences.Hilo;

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

with Util.Log;
with Util.Log.Loggers;
with ADO.Sessions;
with ADO.Model;
with ADO.Objects;
with ADO.SQL;

package body ADO.Sequences.Hilo is

   use Util.Log;
   use ADO.Sessions;
   use Sequence_Maps;
   use ADO.Model;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Sequences.Hilo");

   type HiLoGenerator_Access is access all HiLoGenerator'Class;

   --  ------------------------------
   --  Create a high low sequence generator
   --  ------------------------------
   function Create_HiLo_Generator
     (Sess_Factory : access ADO.Sessions.Factory.Session_Factory'Class)
      return Generator_Access is
      Result : constant HiLoGenerator_Access := new HiLoGenerator;
   begin
      Result.Factory := Sess_Factory;
      return Result.all'Access;
   end Create_HiLo_Generator;

   --  ------------------------------
   --  Allocate an identifier using the generator.
   --  The generator allocates blocks of sequences by using a sequence
   --  table stored in the database.  One database access is necessary
   --  every N allocations.
   --  ------------------------------
   procedure Allocate (Gen : in out HiLoGenerator;
                       Id  : out Identifier) is
   begin
      --  Get a new sequence range
      if Gen.Next_Id >= Gen.Last_Id then
         Allocate_Sequence (Gen);
      end if;

      Id := Gen.Next_Id;
      Gen.Next_Id := Gen.Next_Id + 1;
   end Allocate;

   --  ------------------------------
   --  Allocate a new sequence block.
   --  ------------------------------
   procedure Allocate_Sequence (Gen : in out HiLoGenerator) is
      Name      : constant String := Get_Sequence_Name (Gen);
      Value     : Identifier;
      Seq_Block : Sequence_Ref;
      DB        : Master_Session'Class := Gen.Get_Session;
   begin
      loop
         --  Allocate a new sequence within a transaction.
         declare
            Query : ADO.SQL.Query;
            Found : Boolean;
         begin
            Log.Info ("Allocate sequence range for {0}", Name);

            DB.Begin_Transaction;
            Query.Set_Filter ("name = ?");
            Query.Bind_Param (Position => 1, Value => Name);
            Seq_Block.Find (Session => DB, Query => Query, Found => Found);

            begin
               if Found then
                  Value := Seq_Block.Get_Value;
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               else
                  Value := 1;
                  Seq_Block.Set_Name (Name);
                  Seq_Block.Set_Block_Size (Gen.Block_Size);
                  Seq_Block.Set_Value (Value + Seq_Block.Get_Block_Size);
                  Seq_Block.Save (DB);
               end if;
               DB.Commit;

               Gen.Next_Id := Value;
               Gen.Last_Id := Seq_Block.Get_Value;
               return;

            exception
               when ADO.Objects.LAZY_LOCK =>
                  Log.Info ("Sequence table modified, retrying");
                  DB.Rollback;
            end;

         exception
            when E : others =>
               Log.Error ("Cannot allocate sequence range", E);
               raise;
         end;
      end loop;
   end Allocate_Sequence;

end ADO.Sequences.Hilo;

Update query parameters for the new model


-----------------------------------------------------------------------
--  users - User creation, password tests
--  Copyright (C) 2009, 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 Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Module;
with AWA.Users.Services.Tests.Helpers;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         t.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      Helpers.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Helpers.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : Helpers.Test_User;
      T1        : constant Ada.Calendar.Time := Ada.Calendar.Clock;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         Helpers.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      Helpers.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");
         Util.Tests.Assert_Equals (T, T1,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date 3");

         T.Assert (T2 >= S1.Get_Start_Date.Value, "Start date is invalid 1");
         T.Assert (T1 <= S1.Get_Start_Date.Value + 1.0, "Start date is invalid 2");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      Principal : Helpers.Test_User;
      Key     : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      Helpers.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key      => Key.Get_Access_Key,
                                           Password => "newadmin",
                                           IpAddr   => "192.168.1.2",
                                           User     => Principal.User,
                                           Session  => Principal.Session);

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      Helpers.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Module.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Module.User_Module_Access := AWA.Users.Module.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Module.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Module.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

-----------------------------------------------------------------------
--  users - User creation, password tests
--  Copyright (C) 2009, 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 Util.Test_Caller;
with Util.Measures;

with ADO;
with ADO.Sessions;
with ADO.SQL;
with ADO.Objects;
with Ada.Calendar;

with AWA.Users.Module;
with AWA.Users.Services.Tests.Helpers;
package body AWA.Users.Services.Tests is

   use Util.Tests;
   use ADO;
   use ADO.Objects;

   package Caller is new Util.Test_Caller (Test);

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Create_User",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Authenticate, Close_Session",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Module.Get_User_Module",
                       Test_Get_Module'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session must be created");
      T.Assert (Principal.Session.Get_End_Date.Is_Null, "Session must be opened");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         t.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session must be started");
         T.Assert (S1.Get_End_Date.Is_Null, "Session must not be finished");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Create_User;

   --  ------------------------------
   --  Test logout of a user
   --  ------------------------------
   procedure Test_Logout_User (T : in out Test) is
      Principal : Helpers.Test_User;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");

      Helpers.Logout (Principal);

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (False, "Verify_Session should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;

      begin
         Helpers.Logout (Principal);

         T.Assert (False, "Second logout should report a non-existent session");

      exception
         when Not_Found =>
            null;
      end;
   end Test_Logout_User;

   --  ------------------------------
   --  Test creation of a user
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type Ada.Calendar.Time;

      Principal : Helpers.Test_User;
      T1        : Ada.Calendar.Time;
   begin
      begin
         Principal.Email.Set_Email ("nobody@gmail.com");
         Helpers.Login (Principal);
         T.Assert (False, "Login succeeded with an invalid user name");

         exception
         when Not_Found =>
            null;
      end;

      --  Create the user
      T1 := Ada.Calendar.Clock;
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      Helpers.Login (Principal);

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      --  Verify the user session
      declare
         S1 : Session_Ref;
         U1 : User_Ref;
         T2 : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      begin
         Principal.Manager.Verify_Session (Id => Principal.Session.Get_Id,
                                           Session => S1, User => U1);

         T.Assert (not S1.Is_Null, "Null session returned by Verify_Session");
         T.Assert (not U1.Is_Null, "Null user returned by Verify_Session");
         T.Assert (not S1.Get_Start_Date.Is_Null, "Session start date must not be null");
         T.Assert (S1.Get_End_Date.Is_Null, "Session end date must be null");
         Util.Tests.Assert_Equals (T, Principal.Session.Get_Start_Date.Value,
                                   S1.Get_Start_Date.Value,
                                   "Invalid start date");
         T.Assert (S1.Get_Start_Date.Value >= T1, "Start date is invalid 1");

         T.Assert (S1.Get_Start_Date.Value >= T2, "Start date is invalid 2");
         T.Assert (S1.Get_Start_Date.Value <= T2 + 10.0, "Start date is invalid 3");

         Principal.Manager.Close_Session (Principal.Session.Get_Id);
      end;

   end Test_Login_User;

   --  ------------------------------
   --  Test password reset process
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      Principal : Helpers.Test_User;
      Key     : AWA.Users.Models.Access_Key_Ref;
   begin
      --  Create the user
      Helpers.Create_User (Principal);
      Helpers.Logout (Principal);

      --  Start the lost password process.
      Principal.Manager.Lost_Password (Email => Principal.Email.Get_Email);
      Helpers.Login (Principal);

      --  Get the access key to reset the password
      declare
         DB    : ADO.Sessions.Session := Principal.Manager.Get_Session;
         Query : ADO.SQL.Query;
         Found : Boolean;
      begin
         --  Find the access key
         Query.Set_Filter ("user_id = ?");
         Query.Bind_Param (1, Principal.User.Get_Id);
         Key.Find (DB, Query, Found);
         T.Assert (Found, "Access key for lost_password process not found");

         Principal.Manager.Reset_Password (Key      => Key.Get_Access_Key,
                                           Password => "newadmin",
                                           IpAddr   => "192.168.1.2",
                                           User     => Principal.User,
                                           Session  => Principal.Session);

         --  Search the access key again, it must have been removed.
         Key.Find (DB, Query, Found);
         T.Assert (not Found, "The access key is still present in the database");
      end;

      T.Assert (not Principal.User.Is_Null, "User is created");
      T.Assert (Principal.User.Get_Id > 0, "User has an allocated key");
      T.Assert (Principal.Email.Get_Id > 0, "Email has an allocated key");
      T.Assert (not Principal.Session.Is_Null, "Session is not created");

      Helpers.Logout (Principal);

   end Test_Reset_Password_User;

   --  ------------------------------
   --  Test Get_User_Module operation
   --  ------------------------------
   procedure Test_Get_Module (T : in out Test) is
      use type AWA.Users.Module.User_Module_Access;
   begin
      declare
         M : constant AWA.Users.Module.User_Module_Access := AWA.Users.Module.Get_User_Module;
      begin
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
      declare
         S : Util.Measures.Stamp;
         M : AWA.Users.Module.User_Module_Access;
      begin
         for I in 1 .. 1_000 loop
            M := AWA.Users.Module.Get_User_Module;
         end loop;
         Util.Measures.Report (S, "Get_User_Module (1000)");
         T.Assert (M /= null, "Get_User_Module returned null");
      end;
   end Test_Get_Module;

end AWA.Users.Services.Tests;

Fix test check on dates

Fix test check on dates


-----------------------------------------------------------------------
--  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.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
--  with Security.Permissions;
with Security.Permissions.Tests;
with Security.Policies.URLs;

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

      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           : constant Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
      U           : constant 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;
      Context      : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access;
   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
         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URL : constant String := "/admin/list.html";
               P   : constant URLs.URL_Permission (URL'Length)
                 := URLs.URL_Permission '(Len => URL'Length, URL => URL);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P),
                         "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;
                           URL   : in String) is
      M           : aliased Security.Policies.Policy_Manager (2);
      User        : aliased Test_Principal;
      Admin       : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      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.URL_Permission (URL'Length)
           := URLs.URL_Permission '(Len => URL'Length, URL => URL);
      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.  URL=" & URL);

         --  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.  URL=" & URL);
      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",
                      URL  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URL  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URL  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URL  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URL  => "/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.Files;
with Util.Test_Caller;
with Util.Measures;

with Security.Contexts;
with Security.Policies.Roles;
--  with Security.Permissions;
with Security.Permissions.Tests;
with Security.Policies.URLs;

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

      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           : constant Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
      U           : constant 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;
      Context      : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access;
   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
         S : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               URL : constant String := "/admin/list.html";
               P   : constant URLs.URL_Permission (URL'Length)
                 := URLs.URL_Permission '(Len => URL'Length, URL => URL);
            begin
               T.Assert (Contexts.Has_Permission (Permission => P),
                         "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;
                           URL   : in String) is
      M           : aliased Security.Policies.Policy_Manager (2);
      User        : aliased Test_Principal;
      Admin       : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      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.URL_Permission (URL'Length)
           := URLs.URL_Permission '(Len => URL'Length, URL => URL);
      begin
         --  A user without the role should not have the permission.
         T.Assert (not U.Has_Permission (Context    => Context,
                                         Permission => P),
           "Permission was granted for user without role.  URL=" & URL);

         --  Set the role.
         User.Roles (Admin) := True;
         T.Assert (U.Has_Permission (Context    => Context,
                                     Permission => P),
           "Permission was not granted for user with role.  URL=" & URL);
      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",
                      URL  => "/developer/user-should-have-developer-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URL  => "/developer/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "manager",
                      URL  => "/manager/user-should-have-manager-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URL  => "/manager/user-should-have-admin-role");
      T.Check_Policy (File => "policy-with-role.xml",
                      Role => "admin",
                      URL  => "/admin/user-should-have-admin-role");
   end Test_Role_Policy;

end Security.Policies.Tests;

Simplify calls to Has_Permission

Simplify calls to Has_Permission


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

   use Wiki.Helpers;
   use Wiki.Nodes;
   use Wiki.Strings;
   use Wiki.Buffers;

   --  Parse an image.
   --  Example:
   --    ((url|alt text))
   --    ((url|alt text|position))
   --    ((url|alt text|position||description))
   procedure Parse_Image (Parser  : in out Parser_Type;
                          Text    : in out Wiki.Buffers.Buffer_Access;
                          From    : in out Positive);

   procedure Parse_Preformatted (Parser : in out Parser_Type;
                                 Text   : in out Wiki.Buffers.Buffer_Access;
                                 From   : in out Positive);

   procedure Parse_Preformatted (Parser : in out Parser_Type;
                                 Text   : in out Wiki.Buffers.Buffer_Access;
                                 From   : in out Positive) is
      Count : constant Natural := Count_Occurence (Text, From, '/');
   begin
      if Count /= 3 then
         return;
      end if;

      --  Extract the format either 'Ada' or '[Ada]'
      declare
         Pos    : Natural := Count + 1;
         Buffer : Wiki.Buffers.Buffer_Access := Text;
         Space_Count : Natural;
      begin
         Wiki.Strings.Clear (Parser.Preformat_Format);
         Buffers.Skip_Spaces (Buffer, Pos, Space_Count);
         if Buffer /= null and then Pos <= Buffer.Last and then Buffer.Content (Pos) = '[' then
            Next (Buffer, Pos);
            Common.Parse_Token (Buffer, Pos, Parser.Escape_Char, ']', ']',
                                Parser.Preformat_Format);
            if Buffer /= null then
               Next (Buffer, Pos);
            end if;
         else
            Common.Parse_Token (Buffer, Pos, Parser.Escape_Char, CR, LF,
                                Parser.Preformat_Format);
         end if;
         if Buffer /= null then
            Buffers.Skip_Spaces (Buffer, Pos, Space_Count);
         end if;
         Text := Buffer;
         From := Pos;
      end;

      Parser.Preformat_Indent := 0;
      Parser.Preformat_Fence := ' ';
      Parser.Preformat_Fcount := 0;
      Flush_Text (Parser, Trim => Right);
      Pop_Block (Parser);
      Push_Block (Parser, N_PREFORMAT);
   end Parse_Preformatted;

   --  ------------------------------
   --  Parse an image.
   --  Example:
   --    ((url|alt text))
   --    ((url|alt text|position))
   --    ((url|alt text|position||description))
   --  ------------------------------
   procedure Parse_Image (Parser  : in out Parser_Type;
                          Text    : in out Wiki.Buffers.Buffer_Access;
                          From    : in out Positive) is
      procedure Append_Position (Position : in Wiki.Strings.WString);

      procedure Append_Position (Position : in Wiki.Strings.WString) is
      begin
         if Position = "L" or Position = "G" then
            Wiki.Attributes.Append (Parser.Attributes, String '("align"), "left");
         elsif Position = "R" or Position = "D" then
            Wiki.Attributes.Append (Parser.Attributes, String '("align"), "right");
         elsif Position = "C" then
            Wiki.Attributes.Append (Parser.Attributes, String '("align"), "center");
         end if;
      end Append_Position;

      procedure Append_Position is
         new Wiki.Strings.Wide_Wide_Builders.Get (Append_Position);

      Link     : Wiki.Strings.BString (128);
      Alt      : Wiki.Strings.BString (128);
      Position : Wiki.Strings.BString (128);
      Desc     : Wiki.Strings.BString (128);
      Block    : Wiki.Buffers.Buffer_Access := Text;
      Pos      : Positive := From;
   begin
      Next (Block, Pos);
      if Block = null or else Block.Content (Pos) /= '(' then
         Common.Parse_Text (Parser, Text, From);
         return;
      end if;

      Next (Block, Pos);
      if Block = null then
         Common.Parse_Text (Parser, Text, From, Count => 2);
         return;
      end if;

      Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Link);
      if Block /= null and then Block.Content (Pos) = '|' then
         Next (Block, Pos);
         if Block /= null then
            Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Alt);
         end if;
         if Block /= null and then Block.Content (Pos) = '|' then
            Next (Block, Pos);
            if Block /= null then
               Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Position);
            end if;
            if Block /= null and then Block.Content (Pos) = '|' then
               Next (Block, Pos);
               if Block /= null then
                  Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Desc);
               end if;
            end if;
         end if;
      end if;

      --  Check for the first ')'.
      if Block /= null and then Block.Content (Pos) = ')' then
         Next (Block, Pos);
      end if;

      --  Check for the second ')', abort the image and emit the '((' if the '))' is missing.
      if Block = null or else Block.Content (Pos) /= ')' then
         Common.Parse_Text (Parser, Text, From, Count => 2);
         return;
      end if;
      Next (Block, Pos);
      Text := Block;
      From := Pos;

      Flush_Text (Parser);
      if not Parser.Context.Is_Hidden then
         Wiki.Attributes.Clear (Parser.Attributes);
         Wiki.Attributes.Append (Parser.Attributes, "src", Link);
         Append_Position (Position);
         Wiki.Attributes.Append (Parser.Attributes, "longdesc", Desc);
         Parser.Context.Filters.Add_Image (Parser.Document,
                                           Strings.To_WString (Alt),
                                           Parser.Attributes);
      end if;
   end Parse_Image;

   procedure Parse_Line (Parser : in out Parser_Type;
                         Text   : in Wiki.Buffers.Buffer_Access) is
      Pos    : Natural := 1;
      C      : Wiki.Strings.WChar;
      Count  : Natural;
      Buffer : Wiki.Buffers.Buffer_Access := Text;
   begin
      if Parser.Current_Node = N_PREFORMAT then
         if Parser.Preformat_Fcount = 0 then
            Count := Count_Occurence (Buffer, 1, '/');
            if Count /= 3 then
               Common.Append (Parser.Text, Buffer, 1);
               return;
            end if;
            Pop_Block (Parser);
            return;
         end if;
         if Buffer.Content (Pos) = ' ' then
            Common.Append (Parser.Text, Buffer, Pos + 1);
            return;
         end if;
         Pop_Block (Parser);
      end if;

      if Parser.Quote_Level > 0 then
         Count := Count_Occurence (Buffer, 1, '>');
         if Count = 0 then
            loop
               Pop_Block (Parser);
               exit when Parser.Current_Node = Nodes.N_NONE;
            end loop;
         else
            Pos := Pos + Count;
         end if;
      end if;

      if Parser.Current_Node = N_HEADER then
         Pop_Block (Parser);
      end if;

      C := Buffer.Content (Pos);
      case C is
         when CR | LF =>
            Common.Parse_Paragraph (Parser, Buffer, Pos);
            return;

         when '!' =>
            Common.Parse_Header (Parser, Buffer, Pos, '!');
            if Buffer = null then
               return;
            end if;

         when '/' =>
            Parse_Preformatted (Parser, Buffer, Pos);
            if Buffer = null then
               return;
            end if;

         when ' ' =>
            Parser.Preformat_Indent := 1;
            Parser.Preformat_Fence := ' ';
            Parser.Preformat_Fcount := 1;
            Flush_Text (Parser, Trim => Right);
            Pop_Block (Parser);
            Push_Block (Parser, N_PREFORMAT);
            Common.Append (Parser.Text, Buffer, Pos + 1);
            return;

         when '>' =>
            Count := Count_Occurence (Buffer, Pos + 1, '>');
            if Parser.Current_Node /= N_BLOCKQUOTE then
               Flush_Text (Parser, Trim => Right);
               Pop_Block (Parser);
               Parser.Quote_Level := Count + 1;
               Push_Block (Parser, N_BLOCKQUOTE);
            end if;
            if not Parser.Context.Is_Hidden then
               Parser.Context.Filters.Add_Blockquote (Parser.Document, Parser.Quote_Level);
            end if;
            Pos := Pos + Count + 1;

         when '-' =>
            Common.Parse_Horizontal_Rule (Parser, Buffer, Pos, '-');
            if Buffer = null then
               return;
            end if;

         when '*' | '#' =>
            Common.Parse_List (Parser, Buffer, Pos);

         when others =>
            if Parser.Current_Node /= N_PARAGRAPH then
               Pop_List (Parser);
               Push_Block (Parser, N_PARAGRAPH);
            end if;

      end case;

      Main :
      while Buffer /= null loop
         declare
            Last : Natural := Buffer.Last;
         begin
            while Pos <= Last loop
               C := Buffer.Content (Pos);
               case C is
                  when '_' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '_', Wiki.BOLD);
                     exit Main when Buffer = null;

                  when ''' =>
                     Parse_Format_Double (Parser, Buffer, Pos, ''', Wiki.ITALIC);
                     exit Main when Buffer = null;

                  when '-' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '-', Wiki.STRIKEOUT);
                     exit Main when Buffer = null;

                  when '+' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '+', Wiki.INS);
                     exit Main when Buffer = null;

                  when ',' =>
                     Parse_Format_Double (Parser, Buffer, Pos, ',', Wiki.SUBSCRIPT);
                     exit Main when Buffer = null;

                  when '@' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '@', Wiki.CODE);
                     exit Main when Buffer = null;

                  when '^' =>
                     Parse_Format (Parser, Buffer, Pos, '^', Wiki.SUPERSCRIPT);
                     exit Main when Buffer = null;

                  when '{' =>
                     Common.Parse_Quote (Parser, Buffer, Pos, '{');
                     exit Main when Buffer = null;

                  when '(' =>
                     Parse_Image (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '[' =>
                     Common.Parse_Link (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '<' =>
                     Common.Parse_Template (Parser, Buffer, Pos, '<');
                     exit Main when Buffer = null;

                  when '%' =>
                     Count := Count_Occurence (Buffer, Pos, '%');
                     if Count >= 3 then
                        Parser.Empty_Line := True;
                        Flush_Text (Parser, Trim => Right);
                        if not Parser.Context.Is_Hidden then
                           Parser.Context.Filters.Add_Node (Parser.Document, Nodes.N_LINE_BREAK);
                        end if;

                        --  Skip 3 '%' characters.
                        for I in 1 .. 3 loop
                           Next (Buffer, Pos);
                        end loop;
                        if Buffer /= null and then Helpers.Is_Newline (Buffer.Content (Pos)) then
                           Next (Buffer, Pos);
                        end if;
                        exit Main when Buffer = null;
                     else
                        Append (Parser.Text, C);
                        Pos := Pos + 1;
                     end if;

                  when CR | LF =>
                     --  if Wiki.Strings.Length (Parser.Text) > 0 then
                        Append (Parser.Text, ' ');
                     --  end if;
                     Pos := Pos + 1;

                  when '\' =>
                     Next (Buffer, Pos);
                     if Buffer = null then
                        Append (Parser.Text, C);
                     else
                        Append (Parser.Text, Buffer.Content (Pos));
                        Pos := Pos + 1;
                        Last := Buffer.Last;
                     end if;

                  when others =>
                     Append (Parser.Text, C);
                     Pos := Pos + 1;

               end case;
            end loop;
         end;
         Buffer := Buffer.Next_Block;
         Pos := 1;
      end loop Main;
   end Parse_Line;

end Wiki.Parsers.Dotclear;

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

   use Wiki.Helpers;
   use Wiki.Nodes;
   use Wiki.Strings;
   use Wiki.Buffers;

   --  Parse an image.
   --  Example:
   --    ((url|alt text))
   --    ((url|alt text|position))
   --    ((url|alt text|position||description))
   procedure Parse_Image (Parser  : in out Parser_Type;
                          Text    : in out Wiki.Buffers.Buffer_Access;
                          From    : in out Positive);

   procedure Parse_Preformatted (Parser : in out Parser_Type;
                                 Text   : in out Wiki.Buffers.Buffer_Access;
                                 From   : in out Positive);

   procedure Parse_Preformatted (Parser : in out Parser_Type;
                                 Text   : in out Wiki.Buffers.Buffer_Access;
                                 From   : in out Positive) is
      Count : constant Natural := Count_Occurence (Text, From, '/');
   begin
      if Count /= 3 then
         return;
      end if;

      --  Extract the format either 'Ada' or '[Ada]'
      declare
         Pos    : Natural := Count + 1;
         Buffer : Wiki.Buffers.Buffer_Access := Text;
         Space_Count : Natural;
      begin
         Wiki.Strings.Clear (Parser.Preformat_Format);
         Buffers.Skip_Spaces (Buffer, Pos, Space_Count);
         if Buffer /= null and then Pos <= Buffer.Last and then Buffer.Content (Pos) = '[' then
            Next (Buffer, Pos);
            Common.Parse_Token (Buffer, Pos, Parser.Escape_Char, ']', ']',
                                Parser.Preformat_Format);
            if Buffer /= null then
               Next (Buffer, Pos);
            end if;
         else
            Common.Parse_Token (Buffer, Pos, Parser.Escape_Char, CR, LF,
                                Parser.Preformat_Format);
         end if;
         if Buffer /= null then
            Buffers.Skip_Spaces (Buffer, Pos, Space_Count);
         end if;
         Text := Buffer;
         From := Pos;
      end;

      Parser.Preformat_Indent := 0;
      Parser.Preformat_Fence := ' ';
      Parser.Preformat_Fcount := 0;
      Flush_Text (Parser, Trim => Right);
      Pop_Block (Parser);
      Push_Block (Parser, N_PREFORMAT);
   end Parse_Preformatted;

   --  ------------------------------
   --  Parse an image.
   --  Example:
   --    ((url|alt text))
   --    ((url|alt text|position))
   --    ((url|alt text|position||description))
   --  ------------------------------
   procedure Parse_Image (Parser  : in out Parser_Type;
                          Text    : in out Wiki.Buffers.Buffer_Access;
                          From    : in out Positive) is
      procedure Append_Position (Position : in Wiki.Strings.WString);

      procedure Append_Position (Position : in Wiki.Strings.WString) is
      begin
         if Position = "L" or Position = "G" then
            Wiki.Attributes.Append (Parser.Attributes, String '("align"), "left");
         elsif Position = "R" or Position = "D" then
            Wiki.Attributes.Append (Parser.Attributes, String '("align"), "right");
         elsif Position = "C" then
            Wiki.Attributes.Append (Parser.Attributes, String '("align"), "center");
         end if;
      end Append_Position;

      procedure Append_Position is
         new Wiki.Strings.Wide_Wide_Builders.Get (Append_Position);

      Link     : Wiki.Strings.BString (128);
      Alt      : Wiki.Strings.BString (128);
      Position : Wiki.Strings.BString (128);
      Desc     : Wiki.Strings.BString (128);
      Block    : Wiki.Buffers.Buffer_Access := Text;
      Pos      : Positive := From;
   begin
      Next (Block, Pos);
      if Block = null or else Block.Content (Pos) /= '(' then
         Common.Parse_Text (Parser, Text, From);
         return;
      end if;

      Next (Block, Pos);
      if Block = null then
         Common.Parse_Text (Parser, Text, From, Count => 2);
         return;
      end if;

      Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Link);
      if Block /= null and then Block.Content (Pos) = '|' then
         Next (Block, Pos);
         if Block /= null then
            Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Alt);
         end if;
         if Block /= null and then Block.Content (Pos) = '|' then
            Next (Block, Pos);
            if Block /= null then
               Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Position);
            end if;
            if Block /= null and then Block.Content (Pos) = '|' then
               Next (Block, Pos);
               if Block /= null then
                  Common.Parse_Token (Block, Pos, Parser.Escape_Char, '|', ')', Desc);
               end if;
            end if;
         end if;
      end if;

      --  Check for the first ')'.
      if Block /= null and then Block.Content (Pos) = ')' then
         Next (Block, Pos);
      end if;

      --  Check for the second ')', abort the image and emit the '((' if the '))' is missing.
      if Block = null or else Block.Content (Pos) /= ')' then
         Common.Parse_Text (Parser, Text, From, Count => 2);
         return;
      end if;
      Next (Block, Pos);
      Text := Block;
      From := Pos;

      Flush_Text (Parser);
      if not Parser.Context.Is_Hidden then
         Wiki.Attributes.Clear (Parser.Attributes);
         Wiki.Attributes.Append (Parser.Attributes, "src", Link);
         Append_Position (Position);
         Wiki.Attributes.Append (Parser.Attributes, "longdesc", Desc);
         Parser.Context.Filters.Add_Image (Parser.Document,
                                           Strings.To_WString (Alt),
                                           Parser.Attributes);
      end if;
   end Parse_Image;

   procedure Parse_Line (Parser : in out Parser_Type;
                         Text   : in Wiki.Buffers.Buffer_Access) is
      Pos    : Natural := 1;
      C      : Wiki.Strings.WChar;
      Count  : Natural;
      Buffer : Wiki.Buffers.Buffer_Access := Text;
   begin
      if Parser.In_Blockquote then
         Count := Count_Occurence (Buffer, 1, '>');
         if Count = 0 then
            loop
               Pop_Block (Parser);
               exit when Parser.Current_Node = Nodes.N_NONE;
            end loop;
         else
            Buffers.Next (Buffer, Pos, Count);
            Buffers.Skip_Optional_Space (Buffer, Pos);
            if Buffer = null then
               return;
            end if;
            Push_Block (Parser, Nodes.N_BLOCKQUOTE, Count);
         end if;
      end if;

      if Parser.Current_Node = N_PREFORMAT then
         if Parser.Preformat_Fcount = 0 then
            Count := Count_Occurence (Buffer, 1, '/');
            if Count /= 3 then
               Common.Append (Parser.Text, Buffer, 1);
               return;
            end if;
            Pop_Block (Parser);
            return;
         end if;
         if Buffer.Content (Pos) = ' ' then
            Common.Append (Parser.Text, Buffer, Pos + 1);
            return;
         end if;
         Pop_Block (Parser);
      end if;

      if Parser.Current_Node = N_HEADER then
         Pop_Block (Parser);
      end if;

      C := Buffer.Content (Pos);
      if C = '>' then
         Count := Count_Occurence (Buffer, Pos, '>');
         Push_Block (Parser, Nodes.N_BLOCKQUOTE, Count);
         Buffers.Next (Buffer, Pos, Count);
         Buffers.Skip_Optional_Space (Buffer, Pos);
         if Buffer = null then
            return;
         end if;
         C := Buffer.Content (Pos);
      end if;

      case C is
         when CR | LF =>
            Common.Parse_Paragraph (Parser, Buffer, Pos);
            return;

         when '!' =>
            Common.Parse_Header (Parser, Buffer, Pos, '!');
            if Buffer = null then
               return;
            end if;

         when '/' =>
            Parse_Preformatted (Parser, Buffer, Pos);
            if Buffer = null then
               return;
            end if;

         when ' ' =>
            Parser.Preformat_Indent := 1;
            Parser.Preformat_Fence := ' ';
            Parser.Preformat_Fcount := 1;
            Flush_Text (Parser, Trim => Right);
            if Parser.Current_Node /= N_BLOCKQUOTE then
               Pop_Block (Parser);
            end if;
            Push_Block (Parser, N_PREFORMAT);
            Common.Append (Parser.Text, Buffer, Pos + 1);
            return;

         when '-' =>
            Common.Parse_Horizontal_Rule (Parser, Buffer, Pos, '-');
            if Buffer = null then
               return;
            end if;

         when '*' | '#' =>
            Common.Parse_List (Parser, Buffer, Pos);

         when others =>
            if Parser.Current_Node /= N_PARAGRAPH then
               Pop_List (Parser);
               Push_Block (Parser, N_PARAGRAPH);
            end if;

      end case;

      Main :
      while Buffer /= null loop
         declare
            Last : Natural := Buffer.Last;
         begin
            while Pos <= Last loop
               C := Buffer.Content (Pos);
               case C is
                  when '_' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '_', Wiki.BOLD);
                     exit Main when Buffer = null;

                  when ''' =>
                     Parse_Format_Double (Parser, Buffer, Pos, ''', Wiki.ITALIC);
                     exit Main when Buffer = null;

                  when '-' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '-', Wiki.STRIKEOUT);
                     exit Main when Buffer = null;

                  when '+' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '+', Wiki.INS);
                     exit Main when Buffer = null;

                  when ',' =>
                     Parse_Format_Double (Parser, Buffer, Pos, ',', Wiki.SUBSCRIPT);
                     exit Main when Buffer = null;

                  when '@' =>
                     Parse_Format_Double (Parser, Buffer, Pos, '@', Wiki.CODE);
                     exit Main when Buffer = null;

                  when '^' =>
                     Parse_Format (Parser, Buffer, Pos, '^', Wiki.SUPERSCRIPT);
                     exit Main when Buffer = null;

                  when '{' =>
                     Common.Parse_Quote (Parser, Buffer, Pos, '{');
                     exit Main when Buffer = null;

                  when '(' =>
                     Parse_Image (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '[' =>
                     Common.Parse_Link (Parser, Buffer, Pos);
                     exit Main when Buffer = null;

                  when '<' =>
                     Common.Parse_Template (Parser, Buffer, Pos, '<');
                     exit Main when Buffer = null;

                  when '%' =>
                     Count := Count_Occurence (Buffer, Pos, '%');
                     if Count >= 3 then
                        Parser.Empty_Line := True;
                        Flush_Text (Parser, Trim => Right);
                        if not Parser.Context.Is_Hidden then
                           Parser.Context.Filters.Add_Node (Parser.Document, Nodes.N_LINE_BREAK);
                        end if;

                        --  Skip 3 '%' characters.
                        for I in 1 .. 3 loop
                           Next (Buffer, Pos);
                        end loop;
                        if Buffer /= null and then Helpers.Is_Newline (Buffer.Content (Pos)) then
                           Next (Buffer, Pos);
                        end if;
                        exit Main when Buffer = null;
                     else
                        Append (Parser.Text, C);
                        Pos := Pos + 1;
                     end if;

                  when CR | LF =>
                     --  if Wiki.Strings.Length (Parser.Text) > 0 then
                        Append (Parser.Text, ' ');
                     --  end if;
                     Pos := Pos + 1;

                  when '\' =>
                     Next (Buffer, Pos);
                     if Buffer = null then
                        Append (Parser.Text, C);
                     else
                        Append (Parser.Text, Buffer.Content (Pos));
                        Pos := Pos + 1;
                        Last := Buffer.Last;
                     end if;

                  when others =>
                     Append (Parser.Text, C);
                     Pos := Pos + 1;

               end case;
            end loop;
         end;
         Buffer := Buffer.Next_Block;
         Pos := 1;
      end loop Main;
   end Parse_Line;

end Wiki.Parsers.Dotclear;

Update the parsing of blockquotes

Update the parsing of blockquotes


with Ada.Text_IO; use Ada.Text_IO;

with YAML;

procedure Example is

   procedure Process (S : String);
   procedure Put (N : YAML.Node_Ref; Indent : Natural);

   procedure Process (S : String) is
      P : YAML.Parser_Type;
   begin
      P.Set_Input_String (S, YAML.UTF8_Encoding);
      declare
         D : constant YAML.Document_Type := P.Load;
         N : constant YAML.Node_Ref := D.Root_Node;
      begin
         Put (N, 0);
      end;
      New_Line;
   end Process;

   procedure Put (N : YAML.Node_Ref; Indent : Natural) is
      Prefix : constant String := (1 .. Indent => ' ');
   begin
      case YAML.Kind (N) is
         when YAML.No_Node =>
            Put_Line (Prefix & "<null>");

         when YAML.Scalar_Node =>
            Put_Line (Prefix & String (YAML.Scalar_Value (N)));

         when YAML.Sequence_Node =>
            for I in 1 .. YAML.Sequence_Length (N) loop
               Put_Line (Prefix & "- ");
               Put (YAML.Sequence_Item (N, I), Indent + 2);
            end loop;

         when YAML.Mapping_Node =>
            Put_Line ("Pairs:");
            for I in 1 .. YAML.Mapping_Length (N) loop
               declare
                  Pair : constant YAML.Node_Pair := YAML.Mapping_Item (N, I);
               begin
                  Put (Prefix & "Key:");
                  Put (Pair.Key, Indent + 2);
                  Put (Prefix & "Value:");
                  Put (Pair.Value, Indent + 2);
               end;
            end loop;
      end case;
   end Put;

begin
   Process ("1");
   Process ("[1, 2, 3, a, null]");
   Process ("foo: 1");
end Example;

with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO;      use Ada.Text_IO;

with YAML;

procedure Example is

   procedure Process_String (S : String);
   procedure Process_File (Filename : String);
   procedure Process (D : YAML.Document_Type);
   procedure Put (N : YAML.Node_Ref; Indent : Natural);

   procedure Process_String (S : String) is
      P : YAML.Parser_Type;
   begin
      P.Set_Input_String (S, YAML.UTF8_Encoding);
      Process (P.Load);
   end Process_String;

   procedure Process_File (Filename : String) is
      P : YAML.Parser_Type;
   begin
      P.Set_Input_File (Filename, YAML.UTF8_Encoding);
      Process (P.Load);
   end Process_File;

   procedure Process (D : YAML.Document_Type) is
      N : constant YAML.Node_Ref := D.Root_Node;
   begin
      Put (N, 0);
      New_Line;
   end Process;

   procedure Put (N : YAML.Node_Ref; Indent : Natural) is
      Prefix : constant String := (1 .. Indent => ' ');
   begin
      case YAML.Kind (N) is
         when YAML.No_Node =>
            Put_Line (Prefix & "<null>");

         when YAML.Scalar_Node =>
            Put_Line (Prefix & String (YAML.Scalar_Value (N)));

         when YAML.Sequence_Node =>
            for I in 1 .. YAML.Sequence_Length (N) loop
               Put_Line (Prefix & "- ");
               Put (YAML.Sequence_Item (N, I), Indent + 2);
            end loop;

         when YAML.Mapping_Node =>
            Put_Line ("Pairs:");
            for I in 1 .. YAML.Mapping_Length (N) loop
               declare
                  Pair : constant YAML.Node_Pair := YAML.Mapping_Item (N, I);
               begin
                  Put (Prefix & "Key:");
                  Put (Pair.Key, Indent + 2);
                  Put (Prefix & "Value:");
                  Put (Pair.Value, Indent + 2);
               end;
            end loop;
      end case;
   end Put;

begin
   if Argument_Count = 0 then
      Process_String ("1");
      Process_String ("[1, 2, 3, a, null]");
      Process_String ("foo: 1");
   else
      for I in 1 .. Argument_Count loop
         Process_File (Argument (I));
      end loop;
   end if;
end Example;

Example: enhance to demonstrate the use of Set_Input_File