-----------------------------------------------------------------------
--  util-serialize-io-xml -- XML Serialization Driver
--  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 Unicode;
with Unicode.CES.Utf8;

with Util.Log.Loggers;
package body Util.Serialize.IO.XML is

   use Util.Log;
   use Sax.Readers;
   use Sax.Exceptions;
   use Sax.Locators;
   use Sax.Attributes;
   use Unicode;
   use Unicode.CES;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.XML");

   --  ------------------------------
   --  Warning
   --  ------------------------------
   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Warn ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Warning;

   --  ------------------------------
   --  Error
   --  ------------------------------
   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Error;

   --  ------------------------------
   --  Fatal_Error
   --  ------------------------------
   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Fatal_Error;

   --  ------------------------------
   --  Set_Document_Locator
   --  ------------------------------
   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator) is
   begin
      Handler.Locator := Loc;
   end Set_Document_Locator;

   --  ------------------------------
   --  Start_Document
   --  ------------------------------
   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end Start_Document;

   --  ------------------------------
   --  End_Document
   --  ------------------------------
   overriding
   procedure End_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end End_Document;

   --  ------------------------------
   --  Start_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end Start_Prefix_Mapping;

   --  ------------------------------
   --  End_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end End_Prefix_Mapping;

   --  ------------------------------
   --  Start_Element
   --  ------------------------------
   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class) is
      pragma Unreferenced (Namespace_URI, Qname);

      Attr_Count : Natural;
   begin
--        Handler.Line.Line   := Sax.Locators.Get_Line_Number (Handler.Locator);
--        Handler.Line.Column := Sax.Locators.Get_Column_Number (Handler.Locator);

      Log.Debug ("Start object {0}", Local_Name);

      Handler.Handler.Start_Object (Local_Name);
      Attr_Count := Get_Length (Atts);
      for I in 0 .. Attr_Count - 1 loop
         declare
            Name  : constant String := Get_Qname (Atts, I);
            Value : constant String := Get_Value (Atts, I);
         begin
            Handler.Handler.Set_Member (Name      => Name,
                                        Value     => Util.Beans.Objects.To_Object (Value),
                                        Attribute => True);
         end;
      end loop;
   end Start_Element;

   --  ------------------------------
   --  End_Element
   --  ------------------------------
   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "") is
      pragma Unreferenced (Namespace_URI, Qname);
   begin
      Handler.Handler.Finish_Object (Local_Name);
      if Length (Handler.Text) > 0 then
         Log.Debug ("Close object {0} -> {1}", Local_Name, To_String (Handler.Text));
         Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text));
         Set_Unbounded_String (Handler.Text, "");
      else
         Log.Debug ("Close object {0}", Local_Name);
      end if;
   end End_Element;

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence) is
   begin
      Append (Handler.Text, Content);
   end Collect_Text;

   --  ------------------------------
   --  Characters
   --  ------------------------------
   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      Collect_Text (Handler, Ch);
   end Characters;

   --  ------------------------------
   --  Ignorable_Whitespace
   --  ------------------------------
   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      if not Handler.Ignore_White_Spaces then
         Collect_Text (Handler, Ch);
      end if;
   end Ignorable_Whitespace;

   --  ------------------------------
   --  Processing_Instruction
   --  ------------------------------
   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Processing instruction: {0}: {1}", Target, Data);
   end Processing_Instruction;

   --  ------------------------------
   --  Skipped_Entity
   --  ------------------------------
   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence) is
      pragma Unmodified (Handler);
   begin
      null;
   end Skipped_Entity;

   --  ------------------------------
   --  Start_Cdata
   --  ------------------------------
   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("Start CDATA");
   end Start_Cdata;

   --  ------------------------------
   --  End_Cdata
   --  ------------------------------
   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("End CDATA");
   end End_Cdata;

   --  ------------------------------
   --  Resolve_Entity
   --  ------------------------------
   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Cannot resolve entity {0} - {1}", Public_Id, System_Id);
      return null;
   end Resolve_Entity;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "") is
   begin
      null;
   end Start_DTD;

   --  ------------------------------
   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   --  ------------------------------
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean) is
   begin
      Reader.Ignore_White_Spaces := Value;
   end Set_Ignore_White_Spaces;

   --  ------------------------------
   --  Set the XHTML reader to ignore empty lines.
   --  ------------------------------
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean) is
   begin
      Reader.Ignore_Empty_Lines := Value;
   end Set_Ignore_Empty_Lines;

   --  ------------------------------
   --  Parse an XML stream, and calls the appropriate SAX callbacks for each
   --  event.
   --  This is not re-entrant: you can not call Parse with the same Parser
   --  argument in one of the SAX callbacks. This has undefined behavior.
   --  ------------------------------

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class) is

      type String_Access is access all String (1 .. 32);

      type Stream_Input is new Input_Sources.Input_Source with record
         Index    : Natural;
         Last     : Natural;
         Encoding : Unicode.CES.Encoding_Scheme;
         Buffer   : String_Access;
      end record;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char);

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean;
      procedure Fill (From : in out Stream_Input'Class);

      procedure Fill (From : in out Stream_Input'Class) is
      begin
         --  Move to the buffer start
         if From.Last > From.Index and From.Index > From.Buffer'First then
            From.Buffer (From.Buffer'First .. From.Last - 1 - From.Index + From.Buffer'First) :=
              From.Buffer (From.Index .. From.Last - 1);
            From.Last  := From.Last - From.Index + From.Buffer'First;
            From.Index := From.Buffer'First;
         end if;
         if From.Index > From.Last then
            From.Index := From.Buffer'First;
         end if;
         begin
            loop
               Stream.Read (From.Buffer (From.Last));
               From.Last := From.Last + 1;
               exit when From.Last > From.Buffer'Last;
            end loop;
         exception
            when others =>
               null;
         end;
      end Fill;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char) is
      begin
         if From.Index + 6 >= From.Last then
            Fill (From);
         end if;
         From.Encoding.Read (From.Buffer.all, From.Index, C);
      end Next_Char;

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean is
      begin
         if From.Index < From.Last then
            return False;
         end if;
         return Stream.Is_Eof;
      end Eof;

      Input      : Stream_Input;
      Xml_Parser : Xhtml_Reader;
      Buf        : aliased String (1 .. 32);
   begin
      Input.Buffer := Buf'Access;
      Input.Index  := 2;
      Input.Last   := 1;
      Input.Set_Encoding (Unicode.CES.Utf8.Utf8_Encoding);
      Input.Encoding := Unicode.CES.Utf8.Utf8_Encoding;
      Xml_Parser.Handler := Handler'Unchecked_Access;
      Xml_Parser.Ignore_White_Spaces := Handler.Ignore_White_Spaces;
      Xml_Parser.Ignore_Empty_Lines  := Handler.Ignore_Empty_Lines;
      Sax.Readers.Reader (Xml_Parser).Parse (Input);
   end Parse;

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Output_Stream'Class);

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   --  ------------------------------
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String) is
   begin
      Close_Current (Stream);
      Stream.Write (Value);
   end Write_String;

   --  ------------------------------
   --  Start a new XML object.
   --  ------------------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Close_Start := True;
      Stream.Write ('<');
      Stream.Write (Name);
   end Start_Entity;

   --  ------------------------------
   --  Terminates the current XML object.
   --  ------------------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end End_Entity;

   --  ------------------------------
   --  Write a XML name/value attribute.
   --  ------------------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Stream.Write (' ');
      Stream.Write (Name);
      Stream.Write ("=""");
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ('"');
   end Write_Attribute;

   --  ------------------------------
   --  Write a XML name/value entity (see Write_Attribute).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write (Name);
      Stream.Write ('>');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end Write_Entity;

   --  ------------------------------
   --  Starts a XML array.
   --  ------------------------------
   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type) is
   begin
      null;
   end Start_Array;

   --  ------------------------------
   --  Terminates a XML array.
   --  ------------------------------
   procedure End_Array (Stream : in out Output_Stream) is
   begin
      null;
   end End_Array;

end Util.Serialize.IO.XML;

-----------------------------------------------------------------------
--  util-serialize-io-xml -- XML Serialization Driver
--  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 Unicode;
with Unicode.CES.Utf8;

with Util.Log.Loggers;
package body Util.Serialize.IO.XML is

   use Util.Log;
   use Sax.Readers;
   use Sax.Exceptions;
   use Sax.Locators;
   use Sax.Attributes;
   use Unicode;
   use Unicode.CES;
   use Ada.Strings.Unbounded;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Util.Serialize.IO.XML");

   --  ------------------------------
   --  Warning
   --  ------------------------------
   overriding
   procedure Warning (Handler : in out Xhtml_Reader;
                      Except  : Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Warn ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Warning;

   --  ------------------------------
   --  Error
   --  ------------------------------
   overriding
   procedure Error (Handler : in out Xhtml_Reader;
                    Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Warnings (Off, Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Error;

   --  ------------------------------
   --  Fatal_Error
   --  ------------------------------
   overriding
   procedure Fatal_Error (Handler : in out Xhtml_Reader;
                          Except  : in Sax.Exceptions.Sax_Parse_Exception'Class) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("{0}: {1}", To_String (Get_Locator (Except)), Get_Message (Except));
   end Fatal_Error;

   --  ------------------------------
   --  Set_Document_Locator
   --  ------------------------------
   overriding
   procedure Set_Document_Locator (Handler : in out Xhtml_Reader;
                                   Loc     : in out Sax.Locators.Locator) is
   begin
      Handler.Locator := Loc;
   end Set_Document_Locator;

   --  ------------------------------
   --  Start_Document
   --  ------------------------------
   overriding
   procedure Start_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end Start_Document;

   --  ------------------------------
   --  End_Document
   --  ------------------------------
   overriding
   procedure End_Document (Handler : in out Xhtml_Reader) is
   begin
      null;
   end End_Document;

   --  ------------------------------
   --  Start_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure Start_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                   Prefix  : in Unicode.CES.Byte_Sequence;
                                   URI     : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end Start_Prefix_Mapping;

   --  ------------------------------
   --  End_Prefix_Mapping
   --  ------------------------------
   overriding
   procedure End_Prefix_Mapping (Handler : in out Xhtml_Reader;
                                 Prefix  : in Unicode.CES.Byte_Sequence) is
   begin
      null;
   end End_Prefix_Mapping;

   --  ------------------------------
   --  Start_Element
   --  ------------------------------
   overriding
   procedure Start_Element (Handler       : in out Xhtml_Reader;
                            Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                            Local_Name    : in Unicode.CES.Byte_Sequence := "";
                            Qname         : in Unicode.CES.Byte_Sequence := "";
                            Atts          : in Sax.Attributes.Attributes'Class) is
      pragma Unreferenced (Namespace_URI, Qname);

      Attr_Count : Natural;
   begin
--        Handler.Line.Line   := Sax.Locators.Get_Line_Number (Handler.Locator);
--        Handler.Line.Column := Sax.Locators.Get_Column_Number (Handler.Locator);

      Log.Debug ("Start object {0}", Local_Name);

      Handler.Handler.Start_Object (Local_Name);
      Attr_Count := Get_Length (Atts);
      for I in 0 .. Attr_Count - 1 loop
         declare
            Name  : constant String := Get_Qname (Atts, I);
            Value : constant String := Get_Value (Atts, I);
         begin
            Handler.Handler.Set_Member (Name      => Name,
                                        Value     => Util.Beans.Objects.To_Object (Value),
                                        Attribute => True);
         end;
      end loop;
   end Start_Element;

   --  ------------------------------
   --  End_Element
   --  ------------------------------
   overriding
   procedure End_Element (Handler       : in out Xhtml_Reader;
                          Namespace_URI : in Unicode.CES.Byte_Sequence := "";
                          Local_Name    : in Unicode.CES.Byte_Sequence := "";
                          Qname         : in Unicode.CES.Byte_Sequence := "") is
      pragma Unreferenced (Namespace_URI, Qname);
   begin
      Handler.Handler.Finish_Object (Local_Name);
      if Length (Handler.Text) > 0 then
         Log.Debug ("Close object {0} -> {1}", Local_Name, To_String (Handler.Text));
         Handler.Handler.Set_Member (Local_Name, Util.Beans.Objects.To_Object (Handler.Text));
         Set_Unbounded_String (Handler.Text, "");
      else
         Log.Debug ("Close object {0}", Local_Name);
      end if;
   end End_Element;

   procedure Collect_Text (Handler : in out Xhtml_Reader;
                           Content : Unicode.CES.Byte_Sequence) is
   begin
      Append (Handler.Text, Content);
   end Collect_Text;

   --  ------------------------------
   --  Characters
   --  ------------------------------
   overriding
   procedure Characters (Handler : in out Xhtml_Reader;
                         Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      Collect_Text (Handler, Ch);
   end Characters;

   --  ------------------------------
   --  Ignorable_Whitespace
   --  ------------------------------
   overriding
   procedure Ignorable_Whitespace (Handler : in out Xhtml_Reader;
                                   Ch      : in Unicode.CES.Byte_Sequence) is
   begin
      if not Handler.Ignore_White_Spaces then
         Collect_Text (Handler, Ch);
      end if;
   end Ignorable_Whitespace;

   --  ------------------------------
   --  Processing_Instruction
   --  ------------------------------
   overriding
   procedure Processing_Instruction (Handler : in out Xhtml_Reader;
                                     Target  : in Unicode.CES.Byte_Sequence;
                                     Data    : in Unicode.CES.Byte_Sequence) is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Processing instruction: {0}: {1}", Target, Data);
   end Processing_Instruction;

   --  ------------------------------
   --  Skipped_Entity
   --  ------------------------------
   overriding
   procedure Skipped_Entity (Handler : in out Xhtml_Reader;
                             Name    : in Unicode.CES.Byte_Sequence) is
      pragma Unmodified (Handler);
   begin
      null;
   end Skipped_Entity;

   --  ------------------------------
   --  Start_Cdata
   --  ------------------------------
   overriding
   procedure Start_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("Start CDATA");
   end Start_Cdata;

   --  ------------------------------
   --  End_Cdata
   --  ------------------------------
   overriding
   procedure End_Cdata (Handler : in out Xhtml_Reader) is
      pragma Unmodified (Handler);
   begin
      Log.Info ("End CDATA");
   end End_Cdata;

   --  ------------------------------
   --  Resolve_Entity
   --  ------------------------------
   overriding
   function Resolve_Entity (Handler   : Xhtml_Reader;
                            Public_Id : Unicode.CES.Byte_Sequence;
                            System_Id : Unicode.CES.Byte_Sequence)
                            return Input_Sources.Input_Source_Access is
      pragma Unreferenced (Handler);
   begin
      Log.Error ("Cannot resolve entity {0} - {1}", Public_Id, System_Id);
      return null;
   end Resolve_Entity;

   overriding
   procedure Start_DTD (Handler   : in out Xhtml_Reader;
                        Name      : Unicode.CES.Byte_Sequence;
                        Public_Id : Unicode.CES.Byte_Sequence := "";
                        System_Id : Unicode.CES.Byte_Sequence := "") is
   begin
      null;
   end Start_DTD;

   --  ------------------------------
   --  Set the XHTML reader to ignore or not the white spaces.
   --  When set to True, the ignorable white spaces will not be kept.
   --  ------------------------------
   procedure Set_Ignore_White_Spaces (Reader : in out Parser;
                                      Value  : in Boolean) is
   begin
      Reader.Ignore_White_Spaces := Value;
   end Set_Ignore_White_Spaces;

   --  ------------------------------
   --  Set the XHTML reader to ignore empty lines.
   --  ------------------------------
   procedure Set_Ignore_Empty_Lines (Reader : in out Parser;
                                     Value  : in Boolean) is
   begin
      Reader.Ignore_Empty_Lines := Value;
   end Set_Ignore_Empty_Lines;

   --  ------------------------------
   --  Parse an XML stream, and calls the appropriate SAX callbacks for each
   --  event.
   --  This is not re-entrant: you can not call Parse with the same Parser
   --  argument in one of the SAX callbacks. This has undefined behavior.
   --  ------------------------------

   --  Parse the stream using the JSON parser.
   procedure Parse (Handler : in out Parser;
                    Stream  : in out Util.Streams.Buffered.Buffered_Stream'Class) is

      type String_Access is access all String (1 .. 32);

      type Stream_Input is new Input_Sources.Input_Source with record
         Index    : Natural;
         Last     : Natural;
         Encoding : Unicode.CES.Encoding_Scheme;
         Buffer   : String_Access;
      end record;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char);

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean;
      procedure Fill (From : in out Stream_Input'Class);

      procedure Fill (From : in out Stream_Input'Class) is
      begin
         --  Move to the buffer start
         if From.Last > From.Index and From.Index > From.Buffer'First then
            From.Buffer (From.Buffer'First .. From.Last - 1 - From.Index + From.Buffer'First) :=
              From.Buffer (From.Index .. From.Last - 1);
            From.Last  := From.Last - From.Index + From.Buffer'First;
            From.Index := From.Buffer'First;
         end if;
         if From.Index > From.Last then
            From.Index := From.Buffer'First;
         end if;
         begin
            loop
               Stream.Read (From.Buffer (From.Last));
               From.Last := From.Last + 1;
               exit when From.Last > From.Buffer'Last;
            end loop;
         exception
            when others =>
               null;
         end;
      end Fill;

      --  Return the next character in the string.
      procedure Next_Char (From : in out Stream_Input;
                           C    : out Unicode.Unicode_Char) is
      begin
         if From.Index + 6 >= From.Last then
            Fill (From);
         end if;
         From.Encoding.Read (From.Buffer.all, From.Index, C);
      end Next_Char;

      --  True if From is past the last character in the string.
      function Eof (From : in Stream_Input) return Boolean is
      begin
         if From.Index < From.Last then
            return False;
         end if;
         return Stream.Is_Eof;
      end Eof;

      Input      : Stream_Input;
      Xml_Parser : Xhtml_Reader;
      Buf        : aliased String (1 .. 32);
   begin
      Input.Buffer := Buf'Access;
      Input.Index  := 2;
      Input.Last   := 1;
      Input.Set_Encoding (Unicode.CES.Utf8.Utf8_Encoding);
      Input.Encoding := Unicode.CES.Utf8.Utf8_Encoding;
      Xml_Parser.Handler := Handler'Unchecked_Access;
      Xml_Parser.Ignore_White_Spaces := Handler.Ignore_White_Spaces;
      Xml_Parser.Ignore_Empty_Lines  := Handler.Ignore_Empty_Lines;
      Sax.Readers.Reader (Xml_Parser).Parse (Input);
   end Parse;

   --  Close the current XML entity if an entity was started
   procedure Close_Current (Stream : in out Output_Stream'Class);

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Output_Stream'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   --  ------------------------------
   --  Write the value as a XML string.  Special characters are escaped using the XML
   --  escape rules.
   --  ------------------------------
   procedure Write_String (Stream : in out Output_Stream;
                           Value  : in String) is
   begin
      Close_Current (Stream);
      Stream.Write (Value);
   end Write_String;

   --  ------------------------------
   --  Start a new XML object.
   --  ------------------------------
   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Close_Start := True;
      Stream.Write ('<');
      Stream.Write (Name);
   end Start_Entity;

   --  ------------------------------
   --  Terminates the current XML object.
   --  ------------------------------
   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is
   begin
      Close_Current (Stream);
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end End_Entity;

   --  ------------------------------
   --  Write a XML name/value attribute.
   --  ------------------------------
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Stream.Write (' ');
      Stream.Write (Name);
      Stream.Write ("=""");
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ('"');
   end Write_Attribute;

   --  ------------------------------
   --  Write a XML name/value entity (see Write_Attribute).
   --  ------------------------------
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is
      use Util.Beans.Objects;
   begin
      Close_Current (Stream);
      Stream.Write ('<');
      Stream.Write (Name);
      Stream.Write ('>');
      case Util.Beans.Objects.Get_Type (Value) is
         when TYPE_NULL =>
            null;

         when TYPE_BOOLEAN =>
            if Util.Beans.Objects.To_Boolean (Value) then
               Stream.Write ("true");
            else
               Stream.Write ("false");
            end if;

         when TYPE_INTEGER =>
            Stream.Write (Util.Beans.Objects.To_Long_Long_Integer (Value));

         when others =>
            Stream.Write_String (Util.Beans.Objects.To_String (Value));

      end case;
      Stream.Write ("</");
      Stream.Write (Name);
      Stream.Write ('>');
   end Write_Entity;

   --  ------------------------------
   --  Starts a XML array.
   --  ------------------------------
   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type) is
   begin
      null;
   end Start_Array;

   --  ------------------------------
   --  Terminates a XML array.
   --  ------------------------------
   procedure End_Array (Stream : in out Output_Stream) is
   begin
      null;
   end End_Array;

end Util.Serialize.IO.XML;

Use Stream.Write instead of Stream.Write_String to write the attribute value (otherwise we can close the current entity by writing the '>')


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

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

with Security.Contexts;
with Security.Policies.Roles;
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",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_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;

   --  ------------------------------
   --  Returns true if the given permission is stored in the user principal.
   --  ------------------------------
   function Has_Role (User : in Test_Principal;
                      Role : in Security.Policies.Roles.Role_Type) return Boolean is
   begin
      return User.Roles (Role);
   end Has_Role;

   --  ------------------------------
   --  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;
      Role  : Role_Type;
      Map   : Role_Map := (others => False);
   begin
      M.Create_Role (Name => "manager",
                     Role => Role);
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      T.Assert (not Map (Role), "The admin role must not set in the map");
      M.Set_Roles ("admin", Map);
      T.Assert (Map (Role), "The admin role is not set in the map");
   end Test_Set_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;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      M.Add_Policy (R.all'Access);
      M.Read_Policy (Util.Files.Compose (Path, "empty.xml"));

      R.Add_Role_Type (Name   => "admin",
                       Result => Admin_Perm);
      R.Add_Role_Type (Name   => "manager",
                       Result => Manager_Perm);
      M.Read_Policy (Util.Files.Compose (Path, "simple-policy.xml"));

      User.Roles (Admin_Perm) := True;

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
--        end;
--
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/list.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             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;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (1);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
   begin
      M.Read_Policy (Util.Files.Compose (Path, File));
--
--        Admin_Perm := M.Find_Role (Role);
--
--        Context.Set_Context (Manager   => M'Unchecked_Access,
--                             Principal => User'Unchecked_Access);
--
--        declare
--           P   : constant URI_Permission (URI'Length)
--             := URI_Permission '(Len => URI'Length, URI => URI);
--        begin
--           --  A user without the role should not have the permission.
--           T.Assert (not M.Has_Permission (Context    => Context'Unchecked_Access,
--                                           Permission => P),
--             "Permission was granted for user without role.  URI=" & URI);
--
--           --  Set the role.
--           User.Roles (Admin_Perm) := True;
--           T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                       Permission => P),
--             "Permission was not granted for user with role.  URI=" & URI);
--        end;
   end Check_Policy;

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

end Security.Policies.Tests;

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

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

with Security.Contexts;
with Security.Policies.Roles;
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",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_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;

   --  ------------------------------
   --  Returns true if the given permission is stored in the user principal.
   --  ------------------------------
   function Has_Role (User : in Test_Principal;
                      Role : in Security.Policies.Roles.Role_Type) return Boolean is
   begin
      return User.Roles (Role);
   end Has_Role;

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

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

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

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

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

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

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

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

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

   end Test_Set_Roles;

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

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      M.Add_Policy (R.all'Access);
      M.Read_Policy (Util.Files.Compose (Path, "empty.xml"));

      R.Add_Role_Type (Name   => "admin",
                       Result => Admin_Perm);
      R.Add_Role_Type (Name   => "manager",
                       Result => Manager_Perm);
      M.Read_Policy (Util.Files.Compose (Path, "simple-policy.xml"));

      User.Roles (Admin_Perm) := True;

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
--        end;
--
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/list.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             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;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (1);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
   begin
      M.Read_Policy (Util.Files.Compose (Path, File));
--
--        Admin_Perm := M.Find_Role (Role);
--
--        Context.Set_Context (Manager   => M'Unchecked_Access,
--                             Principal => User'Unchecked_Access);
--
--        declare
--           P   : constant URI_Permission (URI'Length)
--             := URI_Permission '(Len => URI'Length, URI => URI);
--        begin
--           --  A user without the role should not have the permission.
--           T.Assert (not M.Has_Permission (Context    => Context'Unchecked_Access,
--                                           Permission => P),
--             "Permission was granted for user without role.  URI=" & URI);
--
--           --  Set the role.
--           User.Roles (Admin_Perm) := True;
--           T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                       Permission => P),
--             "Permission was not granted for user with role.  URI=" & URI);
--        end;
   end Check_Policy;

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

end Security.Policies.Tests;

Check several roles in Set_Roles

Check several roles in Set_Roles


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

with ADO;
with AWA.Modules;
with AWA.Wikis.Models;
with Security.Permissions;
with Awa.Wikis.Models;
package AWA.Wikis.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "wikis";

   package ACL_Create_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-create");
   package ACL_Delete_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-delete");
   package ACL_Update_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-update");

   --  Define the permissions.
   package ACL_Create_Wiki_Space is new Security.Permissions.Definition ("wiki-space-create");
   package ACL_Delete_Wiki_Space is new Security.Permissions.Definition ("wiki-space-delete");
   package ACL_Update_Wiki_Space is new Security.Permissions.Definition ("wiki-space-update");

   --  ------------------------------
   --  Module wikis
   --  ------------------------------
   type Wiki_Module is new AWA.Modules.Module with private;
   type Wiki_Module_Access is access all Wiki_Module'Class;

   --  Initialize the wikis module.
   overriding
   procedure Initialize (Plugin : in out Wiki_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the wikis module.
   function Get_Wiki_Module return Wiki_Module_Access;

   --  Create the wiki space.
   procedure Create_Wiki_Space (Module : in Wiki_Module;
                                Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Save the wiki space.
   procedure Save_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Load the wiki space.
   procedure Load_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class;
                              Id     : in ADO.Identifier);

   --  Create the wiki page into the wiki space.
   procedure Create_Wiki_Page (Model  : in Wiki_Module;
                               Into   : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                               Page   : in out Awa.Wikis.Models.Wiki_Page_Ref'Class);

   --  Save the wiki page.
   procedure Save (Model  : in Wiki_Module;
                   Page   : in out Awa.Wikis.Models.Wiki_Page_Ref'Class);

   --  Create a new wiki content for the wiki page.
   procedure Create_Wiki_Content (Model   : in Wiki_Module;
                                  Page    : in out Awa.Wikis.Models.Wiki_Page_Ref'Class;
                                  Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

private

   type Wiki_Module is new AWA.Modules.Module with null record;

end AWA.Wikis.Modules;

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

with ADO;
with AWA.Modules;
with AWA.Wikis.Models;
with Security.Permissions;
with AWA.Wikis.Models;
package AWA.Wikis.Modules is

   --  The name under which the module is registered.
   NAME : constant String := "wikis";

   package ACL_Create_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-create");
   package ACL_Delete_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-delete");
   package ACL_Update_Wiki_Pages is new Security.Permissions.Definition ("wiki-page-update");

   --  Define the permissions.
   package ACL_Create_Wiki_Space is new Security.Permissions.Definition ("wiki-space-create");
   package ACL_Delete_Wiki_Space is new Security.Permissions.Definition ("wiki-space-delete");
   package ACL_Update_Wiki_Space is new Security.Permissions.Definition ("wiki-space-update");

   --  ------------------------------
   --  Module wikis
   --  ------------------------------
   type Wiki_Module is new AWA.Modules.Module with private;
   type Wiki_Module_Access is access all Wiki_Module'Class;

   --  Initialize the wikis module.
   overriding
   procedure Initialize (Plugin : in out Wiki_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config);

   --  Get the wikis module.
   function Get_Wiki_Module return Wiki_Module_Access;

   --  Create the wiki space.
   procedure Create_Wiki_Space (Module : in Wiki_Module;
                                Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Save the wiki space.
   procedure Save_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class);

   --  Load the wiki space.
   procedure Load_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class;
                              Id     : in ADO.Identifier);

   --  Create the wiki page into the wiki space.
   procedure Create_Wiki_Page (Model  : in Wiki_Module;
                               Into   : in AWA.Wikis.Models.Wiki_Space_Ref'Class;
                               Page   : in out AWA.Wikis.Models.Wiki_Page_Ref'Class);

   --  Save the wiki page.
   procedure Save (Model  : in Wiki_Module;
                   Page   : in out Awa.Wikis.Models.Wiki_Page_Ref'Class);

   --  Create a new wiki content for the wiki page.
   procedure Create_Wiki_Content (Model   : in Wiki_Module;
                                  Page    : in out AWA.Wikis.Models.Wiki_Page_Ref'Class;
                                  Content : in out AWA.Wikis.Models.Wiki_Content_Ref'Class);

private

   type Wiki_Module is new AWA.Modules.Module with null record;

end AWA.Wikis.Modules;

Fix compilations warnings

Fix compilations warnings


-----------------------------------------------------------------------
--  awa-wikis -- Wiki module
--  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.
-----------------------------------------------------------------------

--  = Wikis Module =
--  The `Wikis` module provides a complete wiki system which allows users to create
--  their own wiki environment with their wiki pages.
--
--  @include awa-wikis-modules.ads
--
--  @include awa-wikis-beans.ads
--
--  == Queries ==
--  @include-query wiki-page.xml
--  @include-query wiki-pages.xml
--  @include-query wiki-history.xml
--  @include-query wiki-list.xml
--
--  == Data model ==
--  [images/awa_wikis_model.png]
--
package AWA.Wikis is

   pragma Preelaborate;

end AWA.Wikis;

-----------------------------------------------------------------------
--  awa-wikis -- Wiki module
--  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.
-----------------------------------------------------------------------

--  = Wikis Module =
--  The `Wikis` module provides a complete wiki system which allows users to create
--  their own wiki environment with their wiki pages.
--
--  @include awa-wikis-modules.ads
--
--  @include awa-wikis-beans.ads
--
--  == Queries ==
--  @include-query wiki-page.xml
--  @include-query wiki-pages.xml
--  @include-query wiki-history.xml
--  @include-query wiki-list.xml
--  @include-query wiki-images.xml
--  @include-query wiki-images-info.xml
--  @include-query wiki-stat.xml
--
--  == Data model ==
--  [images/awa_wikis_model.png]
--
package AWA.Wikis is

   pragma Preelaborate;

end AWA.Wikis;

Add more documentation

Add more documentation


-----------------------------------------------------------------------
--  awa-permissions-controllers -- Permission controllers
--  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 ADO.Sessions;
with ADO.Statements;

with Util.Log.Loggers;

with AWA.Applications;
with AWA.Users.Principals;
with AWA.Permissions.Services;
with AWA.Services.Contexts;
package body AWA.Permissions.Controllers is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Permissions.Controllers");

   --  ------------------------------
   --  Returns true if the user associated with the security context <b>Context</b> has
   --  the permission to access a database entity.  The security context contains some
   --  information about the entity to check and the permission controller will use an
   --  SQL statement to verify the permission.
   --  ------------------------------
   overriding
   function Has_Permission (Handler : in Entity_Controller;
                            Context : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use AWA.Permissions.Services;
      use AWA.Users.Principals;
      use type ADO.Identifier;

      Manager   : constant Permission_Manager_Access := Get_Permission_Manager (Context);
      User_Id   : constant ADO.Identifier := Get_User_Identifier (Context.Get_User_Principal);
      Entity_Id : ADO.Identifier;
   begin
      --  If there is no permission manager, permission is denied.
      if Manager = null or else User_Id = ADO.NO_IDENTIFIER then
         return False;
      end if;

      --  If the user is not logged, permission is denied.
      if Manager = null or else User_Id = ADO.NO_IDENTIFIER then
         Log.Info ("No user identifier in the security context.  Permission is denied");
         return False;
      end if;

      Entity_Id := Entity_Permission'Class (Permission).Entity;

      --  If the security context does not contain the entity identifier, permission is denied.
      if Entity_Id = ADO.NO_IDENTIFIER then
         Log.Info ("No entity identifier in the security context.  Permission is denied");
         return False;
      end if;

      declare
         function Get_Session return ADO.Sessions.Session;

         --  ------------------------------
         --  Get a database session from the AWA application.
         --  There is no guarantee that a AWA.Services.Contexts be available.
         --  But if we are within a service context, we must use the current session so
         --  that we are part of the current transaction.
         --  ------------------------------
         function Get_Session return ADO.Sessions.Session is
            package ASC renames AWA.Services.Contexts;
            use type ASC.Service_Context_Access;

            Ctx : constant ASC.Service_Context_Access := ASC.Current;
         begin
            if Ctx /= null then
               return AWA.Services.Contexts.Get_Session (Ctx);
            else
               return Manager.Get_Application.Get_Session;
            end if;
         end Get_Session;

         Session : constant ADO.Sessions.Session := Get_Session;
         Query   : ADO.Statements.Query_Statement := Session.Create_Statement (Handler.SQL);
         Result  : Integer;
      begin
         --  Build the query
         Query.Bind_Param (Name => "entity_type", Value => Handler.Entity);
         Query.Bind_Param (Name => "entity_id", Value => Entity_Id);
         Query.Bind_Param (Name => "user_id", Value => User_Id);

         --  Run the query.  We must get a single row result and the value must be > 0.
         Query.Execute;

         Result := Query.Get_Result_Integer;
         if Result >= 0 and Query.Has_Elements then
            Log.Info ("Permission granted to {0} on entity {1}",
                      ADO.Identifier'Image (User_Id),
                      ADO.Identifier'Image (Entity_Id));
            return True;
         else
            Log.Info ("Permission denied to {0} on entity {1}",
                      ADO.Identifier'Image (User_Id),
                      ADO.Identifier'Image (Entity_Id));
            return False;
         end if;
      end;
   end Has_Permission;

end AWA.Permissions.Controllers;

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

with ADO.Sessions;
with ADO.Statements;

with Util.Log.Loggers;
with Util.Strings;

with AWA.Applications;
with AWA.Users.Principals;
with AWA.Permissions.Services;
with AWA.Services.Contexts;
package body AWA.Permissions.Controllers is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Permissions.Controllers");

   --  ------------------------------
   --  Returns true if the user associated with the security context <b>Context</b> has
   --  the permission to access a database entity.  The security context contains some
   --  information about the entity to check and the permission controller will use an
   --  SQL statement to verify the permission.
   --  ------------------------------
   overriding
   function Has_Permission (Handler : in Entity_Controller;
                            Context : in Security.Contexts.Security_Context'Class;
                            Permission : in Security.Permissions.Permission'Class)
                            return Boolean is
      use AWA.Permissions.Services;
      use AWA.Users.Principals;
      use type ADO.Identifier;
      use type ADO.Entity_Type;

      Manager   : constant Permission_Manager_Access := Get_Permission_Manager (Context);
      User_Id   : constant ADO.Identifier := Get_User_Identifier (Context.Get_User_Principal);
      Entity_Id : ADO.Identifier;
   begin
      --  If there is no permission manager, permission is denied.
      if Manager = null or else User_Id = ADO.NO_IDENTIFIER then
         return False;
      end if;

      --  If the user is not logged, permission is denied.
      if Manager = null or else User_Id = ADO.NO_IDENTIFIER then
         Log.Info ("No user identifier in the security context.  Permission is denied");
         return False;
      end if;

      Entity_Id := Entity_Permission'Class (Permission).Entity;

      --  If the security context does not contain the entity identifier, permission is denied.
      if Entity_Id = ADO.NO_IDENTIFIER then
         Log.Info ("No entity identifier in the security context.  Permission is denied");
         return False;
      end if;

      declare
         function Get_Session return ADO.Sessions.Session;

         --  ------------------------------
         --  Get a database session from the AWA application.
         --  There is no guarantee that a AWA.Services.Contexts be available.
         --  But if we are within a service context, we must use the current session so
         --  that we are part of the current transaction.
         --  ------------------------------
         function Get_Session return ADO.Sessions.Session is
            package ASC renames AWA.Services.Contexts;
            use type ASC.Service_Context_Access;

            Ctx : constant ASC.Service_Context_Access := ASC.Current;
         begin
            if Ctx /= null then
               return AWA.Services.Contexts.Get_Session (Ctx);
            else
               return Manager.Get_Application.Get_Session;
            end if;
         end Get_Session;

         Session : constant ADO.Sessions.Session := Get_Session;
         Query   : ADO.Statements.Query_Statement := Session.Create_Statement (Handler.SQL);
         Result  : Integer;
      begin
         --  Build the query
         Query.Bind_Param (Name => "entity_id", Value => Entity_Id);
         Query.Bind_Param (Name => "user_id", Value => User_Id);
         if Handler.Entities (2) /= ADO.NO_ENTITY_TYPE then
            for I in Handler.Entities'Range loop
               exit when Handler.Entities (I) = ADO.NO_ENTITY_TYPE;
               Query.Bind_Param (Name  => "entity_type_" & Util.Strings.Image (I),
                                 Value => Handler.Entities (I));
            end loop;
         else
            Query.Bind_Param (Name => "entity_type", Value => Handler.Entities (1));
         end if;

         --  Run the query.  We must get a single row result and the value must be > 0.
         Query.Execute;

         Result := Query.Get_Result_Integer;
         if Result >= 0 and Query.Has_Elements then
            Log.Info ("Permission granted to {0} on entity {1}",
                      ADO.Identifier'Image (User_Id),
                      ADO.Identifier'Image (Entity_Id));
            return True;
         else
            Log.Info ("Permission denied to {0} on entity {1}",
                      ADO.Identifier'Image (User_Id),
                      ADO.Identifier'Image (Entity_Id));
            return False;
         end if;
      end;
   end Has_Permission;

end AWA.Permissions.Controllers;

Configure the SQL permission query according to a list of entity types


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

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

with Security.Contexts;
with Security.Policies.Roles;
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",
                       Test_Read_Policy'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;

   --  ------------------------------
   --  Returns true if the given permission is stored in the user principal.
   --  ------------------------------
   function Has_Role (User : in Test_Principal;
                      Role : in Security.Policies.Roles.Role_Type) return Boolean is
   begin
      return User.Roles (Role);
   end Has_Role;

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

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      M.Add_Policy (R.all'Access);
      M.Read_Policy (Util.Files.Compose (Path, "empty.xml"));

      R.Add_Role_Type (Name   => "admin",
                       Result => Admin_Perm);
      R.Add_Role_Type (Name   => "manager",
                       Result => Manager_Perm);
      M.Read_Policy (Util.Files.Compose (Path, "simple-policy.xml"));

      User.Roles (Admin_Perm) := True;

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
--        end;
--
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/list.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             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;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (1);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
   begin
      M.Read_Policy (Util.Files.Compose (Path, File));
--
--        Admin_Perm := M.Find_Role (Role);
--
--        Context.Set_Context (Manager   => M'Unchecked_Access,
--                             Principal => User'Unchecked_Access);
--
--        declare
--           P   : constant URI_Permission (URI'Length)
--             := URI_Permission '(Len => URI'Length, URI => URI);
--        begin
--           --  A user without the role should not have the permission.
--           T.Assert (not M.Has_Permission (Context    => Context'Unchecked_Access,
--                                           Permission => P),
--             "Permission was granted for user without role.  URI=" & URI);
--
--           --  Set the role.
--           User.Roles (Admin_Perm) := True;
--           T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                       Permission => P),
--             "Permission was not granted for user with role.  URI=" & URI);
--        end;
   end Check_Policy;

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

end Security.Policies.Tests;

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

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

with Security.Contexts;
with Security.Policies.Roles;
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",
                       Test_Read_Policy'Access);
      Caller.Add_Test (Suite, "Test Security.Policies.Roles.Set_Roles",
                       Test_Set_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;

   --  ------------------------------
   --  Returns true if the given permission is stored in the user principal.
   --  ------------------------------
   function Has_Role (User : in Test_Principal;
                      Role : in Security.Policies.Roles.Role_Type) return Boolean is
   begin
      return User.Roles (Role);
   end Has_Role;

   --  ------------------------------
   --  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;
      Role  : Role_Type;
      Map   : Role_Map;
   begin
      M.Create_Role (Name => "manager",
                     Role => Role);
      M.Create_Role (Name => "admin",
                     Role => Role);
      Assert_Equals (T, "admin", M.Get_Role_Name (Role), "Invalid name");

      M.Set_Roles ("admin", Map);
   end Test_Set_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;

   --  ------------------------------
   --  Test reading policy files
   --  ------------------------------
   procedure Test_Read_Policy (T : in out Test) is
      M           : aliased Security.Policies.Policy_Manager (Max_Policies => 2);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Policies.Roles.Role_Type;
      Manager_Perm : Policies.Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
      R            : Security.Policies.Roles.Role_Policy_Access := new Roles.Role_Policy;
   begin
      M.Add_Policy (R.all'Access);
      M.Read_Policy (Util.Files.Compose (Path, "empty.xml"));

      R.Add_Role_Type (Name   => "admin",
                       Result => Admin_Perm);
      R.Add_Role_Type (Name   => "manager",
                       Result => Manager_Perm);
      M.Read_Policy (Util.Files.Compose (Path, "simple-policy.xml"));

      User.Roles (Admin_Perm) := True;

      Context.Set_Context (Manager   => M'Unchecked_Access,
                           Principal => User'Unchecked_Access);
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/" & Util.Strings.Image (I) & "/l.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             Permission => P), "Permission not granted");
--              end;
--           end loop;
--           Util.Measures.Report (S, "Has_Permission (1000 calls, cache miss)");
--        end;
--
--        declare
--           S : Util.Measures.Stamp;
--        begin
--           for I in 1 .. 1_000 loop
--              declare
--                 URI : constant String := "/admin/home/list.html";
--                 P   : constant URI_Permission (URI'Length)
--                   := URI_Permission '(Len => URI'Length, URI => URI);
--              begin
--                 T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                             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;
                           URI : in String) is
      M           : aliased Security.Policies.Policy_Manager (1);
      Dir         : constant String := "regtests/files/permissions/";
      Path        : constant String := Util.Tests.Get_Path (Dir);
      User        : aliased Test_Principal;
      Admin_Perm  : Roles.Role_Type;
      Context     : aliased Security.Contexts.Security_Context;
   begin
      M.Read_Policy (Util.Files.Compose (Path, File));
--
--        Admin_Perm := M.Find_Role (Role);
--
--        Context.Set_Context (Manager   => M'Unchecked_Access,
--                             Principal => User'Unchecked_Access);
--
--        declare
--           P   : constant URI_Permission (URI'Length)
--             := URI_Permission '(Len => URI'Length, URI => URI);
--        begin
--           --  A user without the role should not have the permission.
--           T.Assert (not M.Has_Permission (Context    => Context'Unchecked_Access,
--                                           Permission => P),
--             "Permission was granted for user without role.  URI=" & URI);
--
--           --  Set the role.
--           User.Roles (Admin_Perm) := True;
--           T.Assert (M.Has_Permission (Context    => Context'Unchecked_Access,
--                                       Permission => P),
--             "Permission was not granted for user with role.  URI=" & URI);
--        end;
   end Check_Policy;

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

end Security.Policies.Tests;

Implement the new unit test for Set_Roles