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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Faces;
with ASF.Applications.Messages.Factory;

package body ASF.Contexts.Exceptions is

   --  ------------------------------
   --  Take action to handle the Exception_Event instances that have been queued by
   --  calls to Application.Publish_Event.
   --
   --  This operation is called after each ASF phase by the life cycle manager.
   --  ------------------------------
   procedure Handle (Handler : in out Exception_Handler) is
      pragma Unreferenced (Handler);
      use ASF.Applications;
      use type ASF.Contexts.Faces.Faces_Context_Access;

      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message;

      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class);

      --  ------------------------------
      --  Get a localized message for the exception
      --  ------------------------------
      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message is
         Name : constant String := Event.Get_Exception_Name;
         Msg  : constant String := Event.Get_Exception_Message;
      begin
         if Msg'Length = 0 then
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_BASIC_ID,
                                                 Param1     => Name);
         else
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_EXTENDED_ID,
                                                 Param1     => Name,
                                                 Param2     => Msg);

         end if;
      end Get_Message;

      --  ------------------------------
      --  Process each exception event and add a message in the faces context.
      --  ------------------------------
      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
         Msg : constant Messages.Message := Get_Message (Event, Context);
      begin
         Context.Add_Message (Client_Id => "",
                              Message   => Msg);
         Remove := True;
      end Process;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;

   begin
      if Context = null then
         return;
      end if;
      if Context.Get_Response_Completed then
         return;
      end if;
      Context.Iterate_Exception (Process'Access);
   end Handle;

   --  ------------------------------
   --  Queue an exception event to the exception handler.  The exception event will be
   --  processed at the end of the current ASF phase.
   --  ------------------------------
   procedure Queue_Exception (Queue : in out Exception_Queue;
                              Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      Queue.Unhandled_Events.Append (ASF.Events.Exceptions.Create_Exception_Event (Ex));
   end Queue_Exception;

   --  ------------------------------
   --  Clear the exception queue.
   --  ------------------------------
   overriding
   procedure Finalize (Queue : in out Exception_Queue) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Events.Exceptions.Exception_Event'Class,
                                        Name   => ASF.Events.Exceptions.Exception_Event_Access);

      Len : Natural;
   begin
      loop
         Len := Natural (Queue.Unhandled_Events.Length);
         exit when Len = 0;
         declare
            Event : ASF.Events.Exceptions.Exception_Event_Access
              := Queue.Unhandled_Events.Element (Len);
         begin
            Free (Event);
            Queue.Unhandled_Events.Delete (Len);
         end;
      end loop;
   end Finalize;

end ASF.Contexts.Exceptions;

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

with Ada.Unchecked_Deallocation;

with ASF.Contexts.Faces;
with ASF.Applications.Messages.Factory;

package body ASF.Contexts.Exceptions is

   --  ------------------------------
   --  Take action to handle the Exception_Event instances that have been queued by
   --  calls to Application.Publish_Event.
   --
   --  This operation is called after each ASF phase by the life cycle manager.
   --  ------------------------------
   procedure Handle (Handler : in out Exception_Handler) is
      pragma Unreferenced (Handler);
      use ASF.Applications;
      use type ASF.Contexts.Faces.Faces_Context_Access;

      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message;

      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class);

      --  ------------------------------
      --  Get a localized message for the exception
      --  ------------------------------
      function Get_Message (Event   : in Events.Exceptions.Exception_Event'Class;
                            Context : in ASF.Contexts.Faces.Faces_Context'Class)
                            return ASF.Applications.Messages.Message is
         Name : constant String := Event.Get_Exception_Name;
         Msg  : constant String := Event.Get_Exception_Message;
         Pos  : constant Util.Strings.Maps.Cursor := Handler.Mapping.Find (Name);
      begin
         if Util.Strings.Maps.Has_Element (Pos) then
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => Util.Strings.Maps.Element (Pos),
                                                 Param1     => Msg);
         elsif Msg'Length = 0 then
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_BASIC_ID,
                                                 Param1     => Name);
         else
            return Messages.Factory.Get_Message (Context    => Context,
                                                 Message_Id => EXCEPTION_MESSAGE_EXTENDED_ID,
                                                 Param1     => Name,
                                                 Param2     => Msg);

         end if;
      end Get_Message;

      --  ------------------------------
      --  Process each exception event and add a message in the faces context.
      --  ------------------------------
      procedure Process (Event   : in Events.Exceptions.Exception_Event'Class;
                         Remove  : out Boolean;
                         Context : in out ASF.Contexts.Faces.Faces_Context'Class) is
         Msg : constant Messages.Message := Get_Message (Event, Context);
      begin
         Context.Add_Message (Client_Id => "",
                              Message   => Msg);
         Remove := True;
      end Process;

      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;

   begin
      if Context = null then
         return;
      end if;
      if Context.Get_Response_Completed then
         return;
      end if;
      Context.Iterate_Exception (Process'Access);
   end Handle;

   --  ------------------------------
   --  Set the message id to be used when a given exception name is raised.
   --  ------------------------------
   procedure Set_Message (Handler    : in out Exception_Handler;
                          Name       : in String;
                          Message_Id : in String) is
   begin
      Handler.Mapping.Insert (Name, Message_Id);
   end Set_Message;

   --  ------------------------------
   --  Queue an exception event to the exception handler.  The exception event will be
   --  processed at the end of the current ASF phase.
   --  ------------------------------
   procedure Queue_Exception (Queue : in out Exception_Queue;
                              Ex      : in Ada.Exceptions.Exception_Occurrence) is
   begin
      Queue.Unhandled_Events.Append (ASF.Events.Exceptions.Create_Exception_Event (Ex));
   end Queue_Exception;

   --  ------------------------------
   --  Clear the exception queue.
   --  ------------------------------
   overriding
   procedure Finalize (Queue : in out Exception_Queue) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Events.Exceptions.Exception_Event'Class,
                                        Name   => ASF.Events.Exceptions.Exception_Event_Access);

      Len : Natural;
   begin
      loop
         Len := Natural (Queue.Unhandled_Events.Length);
         exit when Len = 0;
         declare
            Event : ASF.Events.Exceptions.Exception_Event_Access
              := Queue.Unhandled_Events.Element (Len);
         begin
            Free (Event);
            Queue.Unhandled_Events.Delete (Len);
         end;
      end loop;
   end Finalize;

end ASF.Contexts.Exceptions;

Implement Set_Message procedure to register an exception/message mapping Use the mapping table to get a message to be used for a given exception


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

with Ada.Text_IO;
with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
with Util.Test_Caller;
with Util.Log.Loggers;

package body AWA.Commands.Tests is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Commands.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Commands.Start_Stop",
                       Test_Start_Stop'Access);
      Caller.Add_Test (Suite, "Test AWA.Commands.List (tables)",
                       Test_List_Tables'Access);
   end Add_Tests;

   --  ------------------------------
   --  Execute the command and get the output in a string.
   --  ------------------------------
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Input   : in String;
                      Output  : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0) is
      P        : aliased Util.Streams.Pipes.Pipe_Stream;
      Buffer   : Util.Streams.Buffered.Input_Buffer_Stream;
   begin
      if Input'Length > 0 then
         Log.Info ("Execute: {0} < {1}", Command, Input);
      elsif Output'Length > 0 then
         Log.Info ("Execute: {0} > {1}", Command, Output);
      else
         Log.Info ("Execute: {0}", Command);
      end if;
      P.Set_Input_Stream (Input);
      P.Set_Output_Stream (Output);
      P.Open (Command, Util.Processes.READ_ALL);

      --  Write on the process input stream.
      Result := Ada.Strings.Unbounded.Null_Unbounded_String;
      Buffer.Initialize (P'Unchecked_Access, 8192);
      Buffer.Read (Result);
      P.Close;
      Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Result));
      Log.Info ("Command result: {0}", Result);
      Util.Tests.Assert_Equals (T, Status, P.Get_Exit_Status, "Command '" & Command & "' failed");
   end Execute;

   --  ------------------------------
   --  Test start and stop command.
   --  ------------------------------
   procedure Test_Start_Stop (T : in out Test) is

      task Start_Server is
         entry Start;
         entry Wait (Result : out Ada.Strings.Unbounded.Unbounded_String);
      end Start_Server;

      task body Start_Server is
         Output : Ada.Strings.Unbounded.Unbounded_String;
      begin
         accept Start do
            null;
         end Start;
         begin
            T.Execute ("bin/awa_command -c test-sqlite.properties start -m 26123",
                       "", "", Output, 0);
         exception
            when others =>
               Output := Ada.Strings.Unbounded.To_Unbounded_String ("* exception *");
         end;
         accept Wait (Result : out Ada.Strings.Unbounded.Unbounded_String) do
            Result := Output;
         end Wait;
      end Start_Server;

      Result : Ada.Strings.Unbounded.Unbounded_String;
   begin
      --  Launch the 'start' command in a separate task because the command will hang.
      Start_Server.Start;
      delay 5.0;

      --  Launch the 'stop' command, this should terminate the 'start' command.
      T.Execute ("bin/awa_command -c test-sqlite.properties stop -m 26123",
                 "", "", Result, 0);

      --  Wait for the task result.
      Start_Server.Wait (Result);
      Util.Tests.Assert_Matches (T, "Starting...", Result, "AWA start command output");
   end Test_Start_Stop;

   procedure Test_List_Tables (T : in out Test) is
      Config : constant String := Util.Tests.Get_Parameter ("test_config_path");
      Result : Ada.Strings.Unbounded.Unbounded_String;
   begin
      T.Execute ("bin/awa_command -c " & Config & " list -t",
                 "", "", Result, 0);
      Util.Tests.Assert_Matches (T, "awa_audit *[0-9]+", Result, "Missing awa_audit");
      Util.Tests.Assert_Matches (T, "awa_session *[0-9]+", Result, "Missing awa_session");
      Util.Tests.Assert_Matches (T, "entity_type *[0-9]+", Result, "Missing entity_type");
      Util.Tests.Assert_Matches (T, "awa_wiki_page *[0-9]+", Result, "Missing awa_wiki_page");
   end Test_List_Tables;

end AWA.Commands.Tests;

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

with Ada.Text_IO;
with Util.Processes;
with Util.Streams.Pipes;
with Util.Streams.Buffered;
with Util.Test_Caller;
with Util.Log.Loggers;

package body AWA.Commands.Tests is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Commands.Tests");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Commands.Start_Stop",
                       Test_Start_Stop'Access);
      Caller.Add_Test (Suite, "Test AWA.Commands.List (tables)",
                       Test_List_Tables'Access);
   end Add_Tests;

   --  ------------------------------
   --  Execute the command and get the output in a string.
   --  ------------------------------
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Input   : in String;
                      Output  : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0) is
      P        : aliased Util.Streams.Pipes.Pipe_Stream;
      Buffer   : Util.Streams.Buffered.Input_Buffer_Stream;
   begin
      if Input'Length > 0 then
         Log.Info ("Execute: {0} < {1}", Command, Input);
      elsif Output'Length > 0 then
         Log.Info ("Execute: {0} > {1}", Command, Output);
      else
         Log.Info ("Execute: {0}", Command);
      end if;
      P.Set_Input_Stream (Input);
      P.Set_Output_Stream (Output);
      P.Open (Command, Util.Processes.READ_ALL);

      --  Write on the process input stream.
      Result := Ada.Strings.Unbounded.Null_Unbounded_String;
      Buffer.Initialize (P'Unchecked_Access, 8192);
      Buffer.Read (Result);
      P.Close;
      Ada.Text_IO.Put_Line (Ada.Strings.Unbounded.To_String (Result));
      Log.Info ("Command result: {0}", Result);
      Util.Tests.Assert_Equals (T, Status, P.Get_Exit_Status, "Command '" & Command & "' failed");
   end Execute;

   --  ------------------------------
   --  Test start and stop command.
   --  ------------------------------
   procedure Test_Start_Stop (T : in out Test) is

      Config : constant String := Util.Tests.Get_Parameter ("test_config_path");

      task Start_Server is
         entry Start;
         entry Wait (Result : out Ada.Strings.Unbounded.Unbounded_String);
      end Start_Server;

      task body Start_Server is
         Output : Ada.Strings.Unbounded.Unbounded_String;
      begin
         accept Start do
            null;
         end Start;
         begin
            T.Execute ("bin/awa_command -c " & Config & " start -m 26123",
                       "", "", Output, 0);
         exception
            when others =>
               Output := Ada.Strings.Unbounded.To_Unbounded_String ("* exception *");
         end;
         accept Wait (Result : out Ada.Strings.Unbounded.Unbounded_String) do
            Result := Output;
         end Wait;
      end Start_Server;

      Result : Ada.Strings.Unbounded.Unbounded_String;
   begin
      --  Launch the 'start' command in a separate task because the command will hang.
      Start_Server.Start;
      delay 5.0;

      --  Launch the 'stop' command, this should terminate the 'start' command.
      T.Execute ("bin/awa_command -c " & Config & " stop -m 26123",
                 "", "", Result, 0);

      --  Wait for the task result.
      Start_Server.Wait (Result);
      Util.Tests.Assert_Matches (T, "Starting...", Result, "AWA start command output");
   end Test_Start_Stop;

   procedure Test_List_Tables (T : in out Test) is
      Config : constant String := Util.Tests.Get_Parameter ("test_config_path");
      Result : Ada.Strings.Unbounded.Unbounded_String;
   begin
      T.Execute ("bin/awa_command -c " & Config & " list -t",
                 "", "", Result, 0);
      Util.Tests.Assert_Matches (T, "awa_audit *[0-9]+", Result, "Missing awa_audit");
      Util.Tests.Assert_Matches (T, "awa_session *[0-9]+", Result, "Missing awa_session");
      Util.Tests.Assert_Matches (T, "entity_type *[0-9]+", Result, "Missing entity_type");
      Util.Tests.Assert_Matches (T, "awa_wiki_page *[0-9]+", Result, "Missing awa_wiki_page");
   end Test_List_Tables;

end AWA.Commands.Tests;

Fix the start/stop test to use the test configuration file


--  The MIT License (MIT)

--  Copyright (c) 2015 Pavel Zhukov <landgraf@fedoraproject.org>

--  Permission is hereby granted, free of charge, to any person obtaining a copy
--  of this software and associated documentation files (the "Software"), to deal
--  in the Software without restriction, including without limitation the rights
--  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--  copies of the Software, and to permit persons to whom the Software is
--  furnished to do so, subject to the following conditions:

--  The above copyright notice and this permission notice shall be included in all
--  copies or substantial portions of the Software.

--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
--  SOFTWARE.

with Nanomsg.Domains;
with Nanomsg.Pair;
with Aunit.Assertions;
with Nanomsg.Messages;

package body Nanomsg.Test_Pair is
   procedure Run_Test (T : in out TC) is
      use Aunit.Assertions;
      Address : constant String := "tcp://127.0.0.1:5555";
      Request : constant String := "Calculate : 2 + 2";
      Reply : constant String := "Answer: 4";

      Req_Send : Nanomsg.Messages.Message_T;
      Req_Rcv : Nanomsg.Messages.Message_T := Nanomsg.Messages.Empty_Message;
      Rep_Send : Nanomsg.Messages.Message_T;
      Rep_Rcv : Nanomsg.Messages.Message_T := Nanomsg.Messages.Empty_Message;
   begin
      Nanomsg.Messages.From_String (Req_Send, Request);
      Nanomsg.Messages.From_String (Rep_Send, Reply);

      Nanomsg.Socket.Init (T.Socket1, Nanomsg.Domains.Af_Sp, Nanomsg.Pair.Nn_PAIR);
      Nanomsg.Socket.Init (T.Socket2, Nanomsg.Domains.Af_Sp, Nanomsg.Pair.Nn_PAIR);
      Assert (Condition => not T.Socket1.Is_Null, Message => "Failed to initialize socket1");
      Assert (Condition => not T.Socket2.Is_Null, Message => "Failed to initialize socket2");
      Assert (Condition => T.Socket1.Get_Fd /= T.Socket2.Get_Fd,
              Message   => "Descriptors collision!");
      Nanomsg.Socket.Bind (T.Socket2, "tcp://*:5555");
      Nanomsg.Socket.Connect (T.Socket1, Address);

      -- Pair is bi-directional communication
      -- Sendting few messages
      for I in 1 .. 10 loop
         T.Socket1.Send (Req_Send);
         T.Socket2.Receive (Req_Rcv);
         Assert (Condition => Req_Rcv.Text = Request,
                 Message   => "Request damaged in tranmission");
      end loop;

      -- Sending messages in reverse direction
      for I in 1 .. 10 loop
         T.Socket2.Send (Rep_Send);
         T.Socket1.Receive (Rep_Rcv);
         Assert (Condition => Rep_Rcv.Text = Reply,
                 Message   => "Reply damaged in tranmission");
      end loop;

   end Run_Test;

   function Name (T : TC) return Message_String is
   begin
      return Aunit.Format ("Test case name : Pair pattern test");
   end Name;

   procedure Tear_Down (T : in out Tc) is
   begin
      if T.Socket1.Get_Fd >= 0 then
         T.Socket1.Close;
      end if;
      if T.Socket2.Get_Fd >= 0 then
         T.Socket2.Close;
      end if;
   end Tear_Down;

end Nanomsg.Test_Pair;

--  The MIT License (MIT)

--  Copyright (c) 2015 Pavel Zhukov <landgraf@fedoraproject.org>

--  Permission is hereby granted, free of charge, to any person obtaining a copy
--  of this software and associated documentation files (the "Software"), to deal
--  in the Software without restriction, including without limitation the rights
--  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
--  copies of the Software, and to permit persons to whom the Software is
--  furnished to do so, subject to the following conditions:

--  The above copyright notice and this permission notice shall be included in all
--  copies or substantial portions of the Software.

--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
--  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
--  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
--  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
--  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
--  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
--  SOFTWARE.

with Nanomsg.Domains;
with Nanomsg.Pair;
with Aunit.Assertions;
with Nanomsg.Messages;

package body Nanomsg.Test_Pair is
   procedure Run_Test (T : in out TC) is
      use Aunit.Assertions;
      Address : constant String := "tcp://127.0.0.1:5555";
      Request : constant String := "Calculate : 2 + 2";
      Reply : constant String := "Answer: 4";

      Req_Send : Nanomsg.Messages.Message_T;
      Req_Rcv : Nanomsg.Messages.Message_T := Nanomsg.Messages.Empty_Message;
      Rep_Send : Nanomsg.Messages.Message_T;
      Rep_Rcv : Nanomsg.Messages.Message_T := Nanomsg.Messages.Empty_Message;
   begin
      Nanomsg.Messages.From_String (Req_Send, Request);
      Nanomsg.Messages.From_String (Rep_Send, Reply);

      Nanomsg.Socket.Init (T.Socket1, Nanomsg.Domains.Af_Sp, Nanomsg.Pair.Nn_PAIR);
      Nanomsg.Socket.Init (T.Socket2, Nanomsg.Domains.Af_Sp, Nanomsg.Pair.Nn_PAIR);
      Assert (Condition => not T.Socket1.Is_Null, Message => "Failed to initialize socket1");
      Assert (Condition => not T.Socket2.Is_Null, Message => "Failed to initialize socket2");
      Assert (Condition => T.Socket1.Get_Fd /= T.Socket2.Get_Fd,
              Message   => "Descriptors collision!");
      Nanomsg.Socket.Bind (T.Socket2, "tcp://*:5555");
      Nanomsg.Socket.Connect (T.Socket1, Address);

      Assert (Condition => T.Socket1.Is_Ready (To_Send => True, To_Receive => False),
              Message => "Socket 1 is not ready");
      Assert (Condition => T.Socket2.Is_Ready (To_Send => True, To_Receive => False),
              Message => "Socket 2 is not ready");

      -- Pair is bi-directional communication
      -- Sendting few messages
      for I in 1 .. 10 loop
         T.Socket1.Send (Req_Send);
         T.Socket2.Receive (Req_Rcv);
         Assert (Condition => Req_Rcv.Text = Request,
                 Message   => "Request damaged in tranmission");
      end loop;

      -- Sending messages in reverse direction
      for I in 1 .. 10 loop
         T.Socket2.Send (Rep_Send);
         T.Socket1.Receive (Rep_Rcv);
         Assert (Condition => Rep_Rcv.Text = Reply,
                 Message   => "Reply damaged in tranmission");
      end loop;

   end Run_Test;

   function Name (T : TC) return Message_String is
   begin
      return Aunit.Format ("Test case name : Pair pattern test");
   end Name;

   procedure Tear_Down (T : in out Tc) is
   begin
      if T.Socket1.Get_Fd >= 0 then
         T.Socket1.Close;
      end if;
      if T.Socket2.Get_Fd >= 0 then
         T.Socket2.Close;
      end if;
   end Tear_Down;

end Nanomsg.Test_Pair;

Add pair socket test

Add pair socket test


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

with Ada.Strings.Unbounded;
with Util.Tests;
package Gen.Integration.Tests is

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

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

   --  Execute the command and get the output in a string.
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

   --  Test dynamo create-project command.
   procedure Test_Create_Project (T : in out Test);

   --  Test dynamo create-project command --ado.
   procedure Test_Create_ADO_Project (T : in out Test);

   --  Test dynamo create-project command --gtk.
   procedure Test_Create_GTK_Project (T : in out Test);

   --  Test dynamo create-project command --lib.
   procedure Test_Create_Lib_Project (T : in out Test);

   --  Test project configure.
   procedure Test_Configure (T : in out Test);

   --  Test propset command.
   procedure Test_Change_Property (T : in out Test);

   --  Test add-module command.
   procedure Test_Add_Module (T : in out Test);

   --  Test add-model command.
   procedure Test_Add_Model (T : in out Test);

   --  Test add-module-operation command.
   procedure Test_Add_Module_Operation (T : in out Test);

   --  Test add-service command.
   procedure Test_Add_Service (T : in out Test);

   --  Test add-query command.
   procedure Test_Add_Query (T : in out Test);

   --  Test add-page command.
   procedure Test_Add_Page (T : in out Test);

   --  Test add-layout command.
   procedure Test_Add_Layout (T : in out Test);

   --  Test add-ajax-form command.
   procedure Test_Add_Ajax_Form (T : in out Test);

   --  Test generate command.
   procedure Test_Generate (T : in out Test);

   --  Test help command.
   procedure Test_Help (T : in out Test);

   --  Test dist command.
   procedure Test_Dist (T : in out Test);

   --  Test dist with exclude support command.
   procedure Test_Dist_Exclude (T : in out Test);

   --  Test dist command.
   procedure Test_Info (T : in out Test);

   --  Test build-doc command.
   procedure Test_Build_Doc (T : in out Test);

   --  Test generate command with Hibernate XML mapping files.
   procedure Test_Generate_Hibernate (T : in out Test);

   --  Test generate command (XMI enum).
   procedure Test_Generate_XMI_Enum (T : in out Test);

   --  Test generate command (XMI Ada Bean).
   procedure Test_Generate_XMI_Bean (T : in out Test);

   --  Test generate command (XMI Ada Bean with inheritance).
   procedure Test_Generate_XMI_Bean_Table (T : in out Test);

   --  Test generate command (XMI Ada Table).
   procedure Test_Generate_XMI_Table (T : in out Test);

   --  Test generate command (XMI Associations between Tables).
   procedure Test_Generate_XMI_Association (T : in out Test);

   --  Test generate command (XMI Datatype).
   procedure Test_Generate_XMI_Datatype (T : in out Test);

   --  Test generate command using the ArgoUML file directly (runs unzip -cq and parse the output).
   procedure Test_Generate_Zargo_Association (T : in out Test);

   --  Test UML with several tables that have dependencies between each of them (non circular).
   procedure Test_Generate_Zargo_Dependencies (T : in out Test);

   --  Test UML with several tables in several packages (non circular).
   procedure Test_Generate_Zargo_Packages (T : in out Test);

   --  Test UML with serialization code.
   procedure Test_Generate_Zargo_Serialization (T : in out Test);

   --  Test UML with several errors in the UML model.
   procedure Test_Generate_Zargo_Errors (T : in out Test);

   --  Test GNAT compilation of the final project.
   procedure Test_Build (T : in out Test);

   --  Test GNAT compilation of the generated model files.
   procedure Test_Build_Model (T : in out Test);

end Gen.Integration.Tests;

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

with Ada.Strings.Unbounded;
with Util.Tests;
package Gen.Integration.Tests is

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

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

   --  Execute the command and get the output in a string.
   procedure Execute (T       : in out Test;
                      Command : in String;
                      Result  : out Ada.Strings.Unbounded.Unbounded_String;
                      Status  : in Natural := 0);

   --  Test dynamo create-project command.
   procedure Test_Create_Project (T : in out Test);

   --  Test dynamo create-project command --ado.
   procedure Test_Create_ADO_Project (T : in out Test);

   --  Test dynamo create-project command --gtk.
   procedure Test_Create_GTK_Project (T : in out Test);

   --  Test dynamo create-project command --lib.
   procedure Test_Create_Lib_Project (T : in out Test);

   --  Test project configure.
   procedure Test_Configure (T : in out Test);

   --  Test propset command.
   procedure Test_Change_Property (T : in out Test);

   --  Test add-module command.
   procedure Test_Add_Module (T : in out Test);

   --  Test add-model command.
   procedure Test_Add_Model (T : in out Test);

   --  Test add-module-operation command.
   procedure Test_Add_Module_Operation (T : in out Test);

   --  Test add-service command.
   procedure Test_Add_Service (T : in out Test);

   --  Test add-query command.
   procedure Test_Add_Query (T : in out Test);

   --  Test add-page command.
   procedure Test_Add_Page (T : in out Test);

   --  Test add-layout command.
   procedure Test_Add_Layout (T : in out Test);

   --  Test add-ajax-form command.
   procedure Test_Add_Ajax_Form (T : in out Test);

   --  Test generate command.
   procedure Test_Generate (T : in out Test);

   --  Test help command.
   procedure Test_Help (T : in out Test);

   --  Test dist command.
   procedure Test_Dist (T : in out Test);

   --  Test dist with exclude support command.
   procedure Test_Dist_Exclude (T : in out Test);

   --  Test dist command.
   procedure Test_Info (T : in out Test);

   --  Test build-doc command.
   procedure Test_Build_Doc (T : in out Test);

   --  Test build-doc command with -pandoc.
   procedure Test_Build_Pandoc (T : in out Test);

   --  Test generate command with Hibernate XML mapping files.
   procedure Test_Generate_Hibernate (T : in out Test);

   --  Test generate command (XMI enum).
   procedure Test_Generate_XMI_Enum (T : in out Test);

   --  Test generate command (XMI Ada Bean).
   procedure Test_Generate_XMI_Bean (T : in out Test);

   --  Test generate command (XMI Ada Bean with inheritance).
   procedure Test_Generate_XMI_Bean_Table (T : in out Test);

   --  Test generate command (XMI Ada Table).
   procedure Test_Generate_XMI_Table (T : in out Test);

   --  Test generate command (XMI Associations between Tables).
   procedure Test_Generate_XMI_Association (T : in out Test);

   --  Test generate command (XMI Datatype).
   procedure Test_Generate_XMI_Datatype (T : in out Test);

   --  Test generate command using the ArgoUML file directly (runs unzip -cq and parse the output).
   procedure Test_Generate_Zargo_Association (T : in out Test);

   --  Test UML with several tables that have dependencies between each of them (non circular).
   procedure Test_Generate_Zargo_Dependencies (T : in out Test);

   --  Test UML with several tables in several packages (non circular).
   procedure Test_Generate_Zargo_Packages (T : in out Test);

   --  Test UML with serialization code.
   procedure Test_Generate_Zargo_Serialization (T : in out Test);

   --  Test UML with several errors in the UML model.
   procedure Test_Generate_Zargo_Errors (T : in out Test);

   --  Test GNAT compilation of the final project.
   procedure Test_Build (T : in out Test);

   --  Test GNAT compilation of the generated model files.
   procedure Test_Build_Model (T : in out Test);

end Gen.Integration.Tests;

Declare new test Test_Build_Pandoc

Declare new test Test_Build_Pandoc


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

with Ada.Task_Attributes;
with Ada.Unchecked_Deallocation;

package body Security.Contexts is

   use type Security.Policies.Policy_Context_Array_Access;
   use type Security.Policies.Policy_Access;
   use type Security.Policies.Policy_Context_Access;

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

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context'Class,
                                      Name   => Security.Policies.Policy_Context_Access);

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

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

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         return null;
      else
         return Context.Manager.Get_Policy (Name);
      end if;
   end Get_Policy;

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

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

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

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

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

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context_Array,
                                        Name   => Security.Policies.Policy_Context_Array_Access);
   begin
      Task_Context.Set_Value (Context.Previous);
      if Context.Contexts /= null then
         for I in Context.Contexts'Range loop
            Free (Context.Contexts (I));
         end loop;
         Free (Context.Contexts);
      end if;
   end Finalize;

   --  ------------------------------
   --  Set a policy context information represented by Value and associated with
   --  the policy index Policy.
   --  ------------------------------
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access) is
   begin
      if Context.Contexts = null then
         Context.Contexts := Context.Manager.Create_Policy_Contexts;
      end if;
      Free (Context.Contexts (Policy.Get_Policy_Index));
      Context.Contexts (Policy.Get_Policy_Index) := Value;
   end Set_Policy_Context;

   --  ------------------------------
   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   --  ------------------------------
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access is
      Result : Security.Policies.Policy_Context_Access;
   begin
      if Policy = null then
         raise Invalid_Policy;
      end if;
      if Context.Contexts = null then
         raise Invalid_Context;
      end if;
      Result := Context.Contexts (Policy.Get_Policy_Index);
      return Result;
   end Get_Policy_Context;

   --  ------------------------------
   --  Returns True if a context information was registered for the security policy.
   --  ------------------------------
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean is
   begin
      return Policy /= null and then Context.Contexts /= null
        and then Context.Contexts (Policy.Get_Policy_Index) /= null;
   end Has_Policy_Context;

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

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

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

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

end Security.Contexts;

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

with Ada.Task_Attributes;
with Ada.Unchecked_Deallocation;

package body Security.Contexts is

   use type Security.Policies.Policy_Context_Array_Access;
   use type Security.Policies.Policy_Access;
   use type Security.Policies.Policy_Context_Access;

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

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context'Class,
                                      Name   => Security.Policies.Policy_Context_Access);

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

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

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         return null;
      else
         return Context.Manager.Get_Policy (Name);
      end if;
   end Get_Policy;

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

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

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

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

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

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context_Array,
                                        Name   => Security.Policies.Policy_Context_Array_Access);
   begin
      Task_Context.Set_Value (Context.Previous);
      if Context.Contexts /= null then
         for I in Context.Contexts'Range loop
            Free (Context.Contexts (I));
         end loop;
         Free (Context.Contexts);
      end if;
   end Finalize;

   --  ------------------------------
   --  Set a policy context information represented by Value and associated with
   --  the policy index Policy.
   --  ------------------------------
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access) is
   begin
      if Context.Contexts = null then
         Context.Contexts := Context.Manager.Create_Policy_Contexts;
      end if;
      Free (Context.Contexts (Policy.Get_Policy_Index));
      Context.Contexts (Policy.Get_Policy_Index) := Value;
   end Set_Policy_Context;

   --  ------------------------------
   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   --  ------------------------------
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access is
      Result : Security.Policies.Policy_Context_Access;
   begin
      if Policy = null then
         raise Invalid_Policy;
      end if;
      if Context.Contexts = null then
         raise Invalid_Context;
      end if;
      Result := Context.Contexts (Policy.Get_Policy_Index);
      return Result;
   end Get_Policy_Context;

   --  ------------------------------
   --  Returns True if a context information was registered for the security policy.
   --  ------------------------------
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean is
   begin
      return Policy /= null and then Context.Contexts /= null
        and then Context.Contexts (Policy.Get_Policy_Index) /= null;
   end Has_Policy_Context;

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

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

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

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

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

end Security.Contexts;

Implement the Has_Permission function

Implement the Has_Permission function


-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  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 Ada.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Log.Loggers;
with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;

package body Security.Policies is

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

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

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

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

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

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

   --  Get the security controller associated with the permission index <b>Index</b>.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

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

      use Util;

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

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

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Set_Reader_Config (Reader);
      end loop;

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

   end Read_Policy;

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

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

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  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 Ada.Finalization;
with Ada.Strings.Unbounded;

with Ada.Containers.Hashed_Maps;
with Ada.Containers.Vectors;

with Util.Log.Loggers;
with Util.Strings;
with Util.Refs;
with Util.Beans.Objects;
with Util.Beans.Objects.Vectors;
with Util.Serialize.IO.XML;

with GNAT.Regexp;

with Security.Permissions;

package body Security.Policies is

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

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

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

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

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

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

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

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

   --  Get the security controller associated with the permission index <b>Index</b>.
   --  Returns null if there is no such controller.
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

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

      use Util;

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

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

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Set_Reader_Config (Reader);
      end loop;

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

   end Read_Policy;

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

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

end Security.Policies;

Implement the Add_Permission on Policy

Implement the Add_Permission on Policy


-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

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

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

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

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

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

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

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

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

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

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

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

   --  ------------------------------
   --  Get the security controller associated with the permission index Index.
   --  Returns null if there is no such controller.
   --  ------------------------------
   function Get_Controller (Manager : in Policy_Manager'Class;
                            Index   : in Permissions.Permission_Index) return Controller_Access is
      use type Permissions.Permission_Index;
   begin
      if Index >= Manager.Last_Index then
         return null;
      else
         return Manager.Permissions (Index);
      end if;
   end Get_Controller;

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

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

      use Util;

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

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

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

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

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

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

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

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

end Security.Policies;

-----------------------------------------------------------------------
--  security-policies -- Security Policies
--  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 Ada.Unchecked_Deallocation;

with Util.Log.Loggers;

with Security.Controllers;
with Security.Contexts;

package body Security.Policies is

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

   --  Get the policy name.
   function Get_Name (From : in Policy) return String is
   begin
      return "";
   end Get_Name;

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

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

   --  ------------------------------
   --  Permission Manager
   --  ------------------------------

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

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

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

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

      Index : Permission_Index;
   begin
      Log.Info ("Adding permission {0}", Name);

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

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

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

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

      use Util;

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

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

      --  Prepare the reader to parse the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Prepare_Config (Reader);
      end loop;

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

      --  Finish the policy configuration.
      for I in Manager.Policies'Range loop
         exit when Manager.Policies (I) = null;
         Manager.Policies (I).Finish_Config (Reader);
      end loop;

   end Read_Policy;

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

   --  Finalize the permission manager.
   overriding
   procedure Finalize (Manager : in out Policy_Manager) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Security.Controllers.Controller'Class,
                                        Controller_Access);

      procedure Free is
        new Ada.Unchecked_Deallocation (Controller_Access_Array,
                                        Controller_Access_Array_Access);

   begin
      if Manager.Permissions /= null then
         for I in Manager.Permissions.all'Range loop
            exit when Manager.Permissions (I) = null;

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

end Security.Policies;

Remove the Get_Controller function

Remove the Get_Controller function