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

with Ada.Finalization;
with Ada.Strings.Unbounded;

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

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

with GNAT.Regexp;

with Security.Permissions;

package body Security.Policies is

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

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

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

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

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

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

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

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

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

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

      use Util;

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

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

      Reader.Parse (File);

   end Read_Policy;

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

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

end Security.Policies;

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

with Ada.Finalization;
with Ada.Strings.Unbounded;

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

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

with GNAT.Regexp;

with Security.Permissions;

package body Security.Policies is

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

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

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

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

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

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

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

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

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

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

      use Util;

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

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

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

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

   end Read_Policy;

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

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

end Security.Policies;

Configure the XML reader for each policy that was registered in the policy manager


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

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Serialize.Contexts;
with Util.Serialize.Mappers;
with Util.Log.Loggers;
with Util.Stacks;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Start_Array (Stream : in out Output_Stream;
                          Length : in Ada.Containers.Count_Type) is null;

   procedure End_Array (Stream : in out Output_Stream) is null;

   type Parser is abstract new Util.Serialize.Contexts.Context with private;

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

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access);

   --  Dump the mapping tree on the logger using the INFO log level.
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class);

private

   --  Implementation limitation:  the max number of active mapping nodes
   MAX_NODES : constant Positive := 10;

   type Mapper_Access_Array is array (1 .. MAX_NODES) of Serialize.Mappers.Mapper_Access;

   procedure Push (Handler : in out Parser);

   --  Pop the context and restore the previous context when leaving an element
   procedure Pop (Handler  : in out Parser);

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access;

   type Element_Context is record
      --  The object mapper being process.
      Object_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The active mapping nodes.
      Active_Nodes : Mapper_Access_Array;
   end record;
   type Element_Context_Access is access all Element_Context;

   package Context_Stack is new Util.Stacks (Element_Type => Element_Context,
                                             Element_Type_Access => Element_Context_Access);

   type Parser is abstract new Util.Serialize.Contexts.Context with record
      Error_Flag     : Boolean := False;
      Stack          : Context_Stack.Stack;
      Mapping_Tree   : aliased Mappers.Mapper;
      Current_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

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

with Util.Beans.Objects;
with Util.Streams;
with Util.Streams.Buffered;
with Util.Serialize.Contexts;
with Util.Serialize.Mappers;
with Util.Log.Loggers;
with Util.Stacks;
package Util.Serialize.IO is

   Parse_Error : exception;

   --  ------------------------------
   --  Output stream for serialization
   --  ------------------------------
   --  The Output_Stream interface defines the abstract operations for
   --  the serialization framework to write objects on the stream according to
   --  a target format such as XML or JSON.
   type Output_Stream is limited interface and Util.Streams.Output_Stream;

   --  Start a document.
   procedure Start_Document (Stream : in out Output_Stream) is null;

   --  Finish a document.
   procedure End_Document (Stream : in out Output_Stream) is null;

   procedure Start_Entity (Stream : in out Output_Stream;
                           Name   : in String) is null;

   procedure End_Entity (Stream : in out Output_Stream;
                         Name   : in String) is null;

   --  Write the attribute name/value pair.
   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in String) is abstract;

   procedure Write_Wide_Attribute (Stream : in out Output_Stream;
                                   Name   : in String;
                                   Value  : in Wide_Wide_String) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Integer) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Boolean) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream;
                              Name   : in String;
                              Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write the entity value.
   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in String) is abstract;

   procedure Write_Wide_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Wide_Wide_String) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Boolean) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Integer) is abstract;

   procedure Write_Long_Entity (Stream : in out Output_Stream;
                                Name   : in String;
                                Value  : in Long_Long_Integer) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream;
                           Name   : in String;
                           Value  : in Util.Beans.Objects.Object) is abstract;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String);

   procedure Start_Array (Stream : in out Output_Stream;
                          Name   : in String) is null;

   procedure End_Array (Stream : in out Output_Stream;
                        Name   : in String) is null;

   type Parser is abstract new Util.Serialize.Contexts.Context with private;

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

   --  Read the file and parse it using the parser.
   procedure Parse (Handler : in out Parser;
                    File    : in String);

   --  Parse the content string.
   procedure Parse_String (Handler : in out Parser;
                           Content : in String);

   --  Returns true if the Parse operation detected at least one error.
   function Has_Error (Handler : in Parser) return Boolean;

   --  Set the error logger to report messages while parsing and reading the input file.
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access);

   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String);

   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String);

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String);

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String);

   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False);

   --  Get the current location (file and line) to report an error message.
   function Get_Location (Handler : in Parser) return String;

   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   procedure Error (Handler : in out Parser;
                    Message : in String);

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access);

   --  Dump the mapping tree on the logger using the INFO log level.
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class);

private

   --  Implementation limitation:  the max number of active mapping nodes
   MAX_NODES : constant Positive := 10;

   type Mapper_Access_Array is array (1 .. MAX_NODES) of Serialize.Mappers.Mapper_Access;

   procedure Push (Handler : in out Parser);

   --  Pop the context and restore the previous context when leaving an element
   procedure Pop (Handler  : in out Parser);

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access;

   type Element_Context is record
      --  The object mapper being process.
      Object_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The active mapping nodes.
      Active_Nodes : Mapper_Access_Array;
   end record;
   type Element_Context_Access is access all Element_Context;

   package Context_Stack is new Util.Stacks (Element_Type => Element_Context,
                                             Element_Type_Access => Element_Context_Access);

   type Parser is abstract new Util.Serialize.Contexts.Context with record
      Error_Flag     : Boolean := False;
      Stack          : Context_Stack.Stack;
      Mapping_Tree   : aliased Mappers.Mapper;
      Current_Mapper : Util.Serialize.Mappers.Mapper_Access;

      --  The file name to use when reporting errors.
      File           : Ada.Strings.Unbounded.Unbounded_String;

      --  The logger which is used to report error messages when parsing an input file.
      Error_Logger   : Util.Log.Loggers.Logger_Access := null;
   end record;

end Util.Serialize.IO;

Declare Start_Document, End_Document, Write_Attribute, Write_Entity, Write_Wide_Attribute, Write_Wite_Entity procedures for the output stream


-----------------------------------------------------------------------
--  awa-events -- AWA Events
--  Copyright (C) 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.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Beans.Objects.Maps;

with ADO;

--  == Introduction ==
--  The AWA.Events package defines an event framework for modules to post events
--  and have Ada bean methods be invoked when these events are dispatched.  Subscription to
--  events is done through configuration files.  This allows to configure the modules and
--  integrate them together easily at configuration time.
--
--  === Declaration ===
--  Modules define the events that they can generate by instantiating the Definition
--  package. This is a static definition of the event.  Each event is given a unique name.
--
--    package Event_New_User is new AWA.Events.Definition ("new-user");
--
--  === Posting an event ===
--  The module can post an event to inform other modules or the system that a particular
--  action occurred.  The module creates the event instance of type Module_Event and
--  populates that event with useful properties for event receivers.
--
--    Event : AWA.Events.Module_Event;
--
--    Event.Set_Event_Kind (Event_New_User.Kind);
--    Event.Set_Parameter ("email", "harry.potter@hogwarts.org");
--
--  The module will post the event by using the Send_Event operation.
--
--    Manager.Send_Event (Event);
--
--  === Receiving an event ===
--  Modules or applications interested by a particular event will configure the event manager
--  to dispatch the event to an Ada bean event action.  The Ada bean is an object that must
--  implement a procedure that matches the prototype:
--
--    type Action_Bean is new Util.Beans.Basic.Readonly_Bean ...;
--    procedure Action (Bean : in out Action_Bean; Event : in AWA.Events.Module_Event'Class);
--
--  The Ada bean method and object are registered as other Ada beans.
--
--  The configuration file indicates how to bind the Ada bean action and the event together.
--  The action is specified using an EL Method Expression (See Ada EL or JSR 245).
--
--    <on-event name="new_user">
--        <action>#{ada_bean.action}</action>
--    </on-event>
--
--  === Event queues and dispatchers ===
--  The *AWA.Events* framework posts events on queues and it uses a dispatcher to process them.
--  There are two kinds of dispatchers:
--
--    * Synchronous dispatcher process the event when it is posted.  The task which posts
--      the event invokes the Ada bean action.  In this dispatching mode, there is no event queue.
--      If the action method raises an exception, it will however be blocked.
--
--    * Asynchronous dispatcher are executed by dedicated tasks.  The event is put in an event
--      queue.  A dispatcher task processes the event and invokes the action method at a later
--      time.
--
--  When the event is queued, there are two types of event queues:
--
--    * A Fifo memory queue manages the event and dispatches them in FIFO order.
--      If the application is stopped, the events present in the Fifo queue are lost.
--
--    * A persistent event queue manages the event in a similar way as the FIFO queue but
--      saves them in the database.  If the application is stopped, events that have not yet
--      been processed will be dispatched when the application is started again.
--
--  == Data Model ==
--  @include Queues.hbm.xml
--
package AWA.Events is

   type Queue_Index is new Natural;
   type Event_Index is new Natural;

   --  ------------------------------
   --  Event kind definition
   --  ------------------------------
   --  This package must be instantiated for each event that a module can post.
   generic
      Name : String;
   package Definition is
      function Kind return Event_Index;
      pragma Inline_Always (Kind);
   end Definition;

   --  Exception raised if an event name is not found.
   Not_Found : exception;

   --  Identifies an invalid event.
   Invalid_Event : constant Event_Index := 0;

   --  Find the event runtime index given the event name.
   --  Raises Not_Found exception if the event name is not recognized.
   function Find_Event_Index (Name : in String) return Event_Index;

   --  ------------------------------
   --  Module event
   --  ------------------------------
   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with private;
   type Module_Event_Access is access all Module_Event'Class;

   --  Set the event type which identifies the event.
   procedure Set_Event_Kind (Event : in out Module_Event;
                             Kind  : in Event_Index);

   --  Get the event type which identifies the event.
   function Get_Event_Kind (Event : in Module_Event) return Event_Index;

   --  Set a parameter on the message.
   procedure Set_Parameter (Event  : in out Module_Event;
                            Name   : in String;
                            Value  : in String);

   --  Get the parameter with the given name.
   function Get_Parameter (Event : in Module_Event;
                           Name  : in String) return String;

   --  Get the value that corresponds to the parameter with the given name.
   overriding
   function Get_Value (Event : in Module_Event;
                       Name  : in String) return Util.Beans.Objects.Object;

   --  Get the entity identifier associated with the event.
   function Get_Entity_Identifier (Event : in Module_Event) return ADO.Identifier;

   --  Set the entity identifier associated with the event.
   procedure Set_Entity_Identifier (Event : in out Module_Event;
                                    Id    : in ADO.Identifier);

   --  Copy the event properties to the map passed in <tt>Into</tt>.
   procedure Copy (Event : in Module_Event;
                   Into  : in out Util.Beans.Objects.Maps.Map);

private

   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with record
      Kind        : Event_Index := Invalid_Event;
      Props       : Util.Beans.Objects.Maps.Map;
      Entity      : ADO.Identifier := ADO.NO_IDENTIFIER;
      Entity_Type : ADO.Entity_Type;
   end record;

   --  The index of the last event definition.
   Last_Event : Event_Index := 0;

   --  Get the event type name.
   function Get_Event_Type_Name (Index : in Event_Index) return Util.Strings.Name_Access;

   --  Make and return a copy of the event.
   function Copy (Event : in Module_Event) return Module_Event_Access;

end AWA.Events;

-----------------------------------------------------------------------
--  awa-events -- AWA Events
--  Copyright (C) 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.Strings;
with Util.Events;
with Util.Beans.Objects;
with Util.Beans.Basic;
with Util.Beans.Objects.Maps;

with ADO;

--  == Introduction ==
--  The AWA.Events package defines an event framework for modules to post events
--  and have Ada bean methods be invoked when these events are dispatched.  Subscription to
--  events is done through configuration files.  This allows to configure the modules and
--  integrate them together easily at configuration time.
--
--  === Declaration ===
--  Modules define the events that they can generate by instantiating the Definition
--  package. This is a static definition of the event.  Each event is given a unique name.
--
--    package Event_New_User is new AWA.Events.Definition ("new-user");
--
--  === Posting an event ===
--  The module can post an event to inform other modules or the system that a particular
--  action occurred.  The module creates the event instance of type Module_Event and
--  populates that event with useful properties for event receivers.
--
--    Event : AWA.Events.Module_Event;
--
--    Event.Set_Event_Kind (Event_New_User.Kind);
--    Event.Set_Parameter ("email", "harry.potter@hogwarts.org");
--
--  The module will post the event by using the Send_Event operation.
--
--    Manager.Send_Event (Event);
--
--  === Receiving an event ===
--  Modules or applications interested by a particular event will configure the event manager
--  to dispatch the event to an Ada bean event action.  The Ada bean is an object that must
--  implement a procedure that matches the prototype:
--
--    type Action_Bean is new Util.Beans.Basic.Readonly_Bean ...;
--    procedure Action (Bean : in out Action_Bean; Event : in AWA.Events.Module_Event'Class);
--
--  The Ada bean method and object are registered as other Ada beans.
--
--  The configuration file indicates how to bind the Ada bean action and the event together.
--  The action is specified using an EL Method Expression (See Ada EL or JSR 245).
--
--    <on-event name="new_user">
--        <action>#{ada_bean.action}</action>
--    </on-event>
--
--  === Event queues and dispatchers ===
--  The *AWA.Events* framework posts events on queues and it uses a dispatcher to process them.
--  There are two kinds of dispatchers:
--
--    * Synchronous dispatcher process the event when it is posted.  The task which posts
--      the event invokes the Ada bean action.  In this dispatching mode, there is no event queue.
--      If the action method raises an exception, it will however be blocked.
--
--    * Asynchronous dispatcher are executed by dedicated tasks.  The event is put in an event
--      queue.  A dispatcher task processes the event and invokes the action method at a later
--      time.
--
--  When the event is queued, there are two types of event queues:
--
--    * A Fifo memory queue manages the event and dispatches them in FIFO order.
--      If the application is stopped, the events present in the Fifo queue are lost.
--
--    * A persistent event queue manages the event in a similar way as the FIFO queue but
--      saves them in the database.  If the application is stopped, events that have not yet
--      been processed will be dispatched when the application is started again.
--
--  == Data Model ==
--  @include Queues.hbm.xml
--
package AWA.Events is

   type Queue_Index is new Natural;
   type Event_Index is new Natural;

   --  ------------------------------
   --  Event kind definition
   --  ------------------------------
   --  This package must be instantiated for each event that a module can post.
   generic
      Name : String;
   package Definition is
      function Kind return Event_Index;
      pragma Inline_Always (Kind);
   end Definition;

   --  Exception raised if an event name is not found.
   Not_Found : exception;

   --  Identifies an invalid event.
   Invalid_Event : constant Event_Index := 0;

   --  Find the event runtime index given the event name.
   --  Raises Not_Found exception if the event name is not recognized.
   function Find_Event_Index (Name : in String) return Event_Index;

   --  ------------------------------
   --  Module event
   --  ------------------------------
   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with private;
   type Module_Event_Access is access all Module_Event'Class;

   --  Set the event type which identifies the event.
   procedure Set_Event_Kind (Event : in out Module_Event;
                             Kind  : in Event_Index);

   --  Get the event type which identifies the event.
   function Get_Event_Kind (Event : in Module_Event) return Event_Index;

   --  Set a parameter on the message.
   procedure Set_Parameter (Event  : in out Module_Event;
                            Name   : in String;
                            Value  : in String);

   --  Get the parameter with the given name.
   function Get_Parameter (Event : in Module_Event;
                           Name  : in String) return String;

   --  Get the value that corresponds to the parameter with the given name.
   overriding
   function Get_Value (Event : in Module_Event;
                       Name  : in String) return Util.Beans.Objects.Object;

   --  Get the entity identifier associated with the event.
   function Get_Entity_Identifier (Event : in Module_Event) return ADO.Identifier;

   --  Set the entity identifier associated with the event.
   procedure Set_Entity_Identifier (Event : in out Module_Event;
                                    Id    : in ADO.Identifier);

   --  Copy the event properties to the map passed in <tt>Into</tt>.
   procedure Copy (Event : in Module_Event;
                   Into  : in out Util.Beans.Objects.Maps.Map);

private

   type Module_Event is new Util.Events.Event and Util.Beans.Basic.Readonly_Bean with record
      Kind        : Event_Index := Invalid_Event;
      Props       : Util.Beans.Objects.Maps.Map;
      Entity      : ADO.Identifier  := ADO.NO_IDENTIFIER;
      Entity_Type : ADO.Entity_Type := ADO.NO_ENTITY_TYPE;
   end record;

   --  The index of the last event definition.
   Last_Event : Event_Index := 0;

   --  Get the event type name.
   function Get_Event_Type_Name (Index : in Event_Index) return Util.Strings.Name_Access;

   --  Make and return a copy of the event.
   function Copy (Event : in Module_Event) return Module_Event_Access;

end AWA.Events;

Fix default initialization of a module event


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

   pragma Linker_Options ("-lreadline");

   function Readline (Prompt : in Interfaces.C.Strings.chars_ptr)
                      return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Readline, "readline");

   procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr);
   pragma Import (C, Add_History, "add_history");

   --  ------------------------------
   --  Print the prompt and a read a line from the terminal.
   --  Raise the Ada.IO_Exceptions.End_Error when the EOF is reached.
   --  ------------------------------
   function Get_Line (Prompt : in String) return String is
      use type Interfaces.C.Strings.chars_ptr;

      P : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Prompt);
      R : Interfaces.C.Strings.chars_ptr;
   begin
      R := Readline (P);
      Interfaces.C.Strings.Free (P);
      if R = Interfaces.C.Strings.null_ptr then
         raise Ada.IO_Exceptions.End_Error;
      end if;
      declare
         Result : constant String := Interfaces.C.Strings.Value (R);
      begin
         if Result'Length > 0 then
            Add_History (R);
         end if;
         Interfaces.C.Strings.Free (R);
         return Result;
      end;
   end Get_Line;

end Readline;

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

   pragma Linker_Options ("-lreadline");

   function Readline (Prompt : in Interfaces.C.Strings.chars_ptr)
                      return Interfaces.C.Strings.chars_ptr;
   pragma Import (C, Readline, "readline");

   procedure Add_History (Line : in Interfaces.C.Strings.chars_ptr);
   pragma Import (C, Add_History, "add_history");

   --  ------------------------------
   --  Print the prompt and a read a line from the terminal.
   --  Raise the Ada.IO_Exceptions.End_Error when the EOF is reached.
   --  ------------------------------
   function Get_Line (Prompt : in String) return String is
      use type Interfaces.C.Strings.chars_ptr;

      P : Interfaces.C.Strings.chars_ptr := Interfaces.C.Strings.New_String (Prompt);
      R : Interfaces.C.Strings.chars_ptr;
   begin
      R := Readline (P);
      Interfaces.C.Strings.Free (P);
      if R = Interfaces.C.Strings.Null_Ptr then
         raise Ada.IO_Exceptions.End_Error;
      end if;
      declare
         Result : constant String := Interfaces.C.Strings.Value (R);
      begin
         if Result'Length > 0 then
            Add_History (R);
         end if;
         Interfaces.C.Strings.Free (R);
         return Result;
      end;
   end Get_Line;

end Readline;

Fix minor compilation warnings

Fix minor compilation warnings


-----------------------------------------------------------------------
--  bkp-stores-local -- Store management for local files
--  Copyright (C) 2014, 2015, 2016 Stephane.Carrez
--  Written by Stephane.Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Strings.Unbounded;
with Ada.Streams.Stream_IO;
with Interfaces.C.Strings;
with System.OS_Constants;

with Util.Log.Loggers;
with Util.Files;
with Util.Systems.Os;
with Util.Streams.Raw;
with Util.Systems.Types;
with Util.Systems.Os;
with Interfaces;

with Babel.Streams.Files;
package body Babel.Stores.Local is

   function Errno return Integer;
   pragma Import (C, errno, "__get_errno");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Stores.Local");

   function Get_File_Size (Ent : in Ada.Directories.Directory_Entry_Type) return Babel.Files.File_Size is
      Size : Ada.Directories.File_Size;
   begin
      Size := Ada.Directories.Size (Ent);
      return Babel.Files.File_Size (Size);

   exception
      when Constraint_Error =>
         return Babel.Files.File_Size (Interfaces.Unsigned_32'Last);
   end Get_File_Size;

   --  ------------------------------
   --  Get the absolute path to access the local file.
   --  ------------------------------
   function Get_Absolute_Path (Store : in Local_Store_Type;
                               Path  : in String) return String is
   begin
      if Ada.Strings.Unbounded.Length (Store.Root_Dir) = 0 then
         return Path;
      else
         return Util.Files.Compose (Ada.Strings.Unbounded.To_String (Store.Root_Dir), Path);
      end if;
   end Get_Absolute_Path;

   --  Open a file in the store to read its content with a stream.
   overriding
   procedure Open_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Stream_Access) is
   begin
      null;
   end Open_File;

   --  ------------------------------
   --  Open a file in the store to read its content with a stream.
   --  ------------------------------
   overriding
   procedure Read_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Refs.Stream_Ref) is
      File   : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Buffer : Babel.Files.Buffers.Buffer_Access;
   begin
      Log.Info ("Read file {0}", Path);

      Stream := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      Store.Pool.Get_Buffer (Buffer);
      File.Open (Path, Buffer);
   end Read_File;

   --  ------------------------------
   --  Write a file in the store with a stream.
   --  ------------------------------
   overriding
   procedure Write_File (Store  : in out Local_Store_Type;
                         Path   : in String;
                         Stream : in Babel.Streams.Refs.Stream_Ref;
                         Mode   : in Util.Systems.Types.mode_t) is
      File   : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Output : Babel.Streams.Refs.Stream_Ref;
   begin
      Log.Info ("Write file {0}", Path);

      Output := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      File.Create (Path, Mode);
      Babel.Streams.Refs.Copy (From => Stream,
                               Into => Output);
   end Write_File;

   procedure Read (Store : in out Local_Store_Type;
                   Path  : in String;
                   Into  : in out Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      File     : Ada.Streams.Stream_IO.File_Type;
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
   begin
      Ada.Streams.Stream_IO.Open (File, Ada.Streams.Stream_IO.In_File, Abs_Path);
      Ada.Streams.Stream_IO.Read (File, Into.Data, Into.Last);
      Ada.Streams.Stream_IO.Close (File);
      Log.Info ("Read {0} -> {1}", Abs_Path, Ada.Streams.Stream_Element_Offset'Image (Into.Last));
   end Read;

   procedure Open (Store  : in out Local_Store_Type;
                   Stream : in out Util.Streams.Raw.Raw_Stream;
                   Path   : in String) is
      use Util.Systems.Os;
      use type Interfaces.C.int;

      File : Util.Systems.Os.File_Type;
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
   begin
      File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
      if File < 0 then
         if Errno = System.OS_Constants.ENOENT then
            declare
               Dir : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Ada.Directories.Create_Path (Dir);
            end;
            File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
         end if;
      end if;
      if File < 0 then
         Log.Error ("Cannot create {0}", Path);
         raise Ada.Streams.Stream_IO.Name_Error with "Cannot create " & Path;
      end if;
      Stream.Initialize (File);
      Interfaces.C.Strings.Free (Name);
   end Open;

   procedure Write (Store : in out Local_Store_Type;
                    Path  : in String;
                    Into  : in Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      Stream   : Util.Streams.Raw.Raw_Stream;
   begin
      Log.Info ("Write {0}", Abs_Path);

      Store.Open (Stream, Abs_Path);
      Stream.Write (Into.Data (Into.Data'First .. Into.Last));
      Stream.Close;
   end Write;

   procedure Scan (Store  : in out Local_Store_Type;
                   Path   : in String;
                   Into   : in out Babel.Files.File_Container'Class;
                   Filter : in Babel.Filters.Filter_Type'Class) is
      use Ada.Directories;
      use type Babel.Files.File_Type;
      use type Babel.Files.Directory_Type;

      function Sys_Stat (Path : in System.Address;
                         Stat : access Util.Systems.Types.Stat_Type) return Integer;
      pragma Import (C, Sys_Stat, "stat");

      Search_Filter : constant Ada.Directories.Filter_Type := (Ordinary_File => True,
                                                               Ada.Directories.Directory => True,
                                                               Special_File => False);
      Search   : Search_Type;
      Ent      : Directory_Entry_Type;
      Stat     : aliased Util.Systems.Types.Stat_Type;
   begin
      Log.Info ("Scan directory {0}", Path);

      Start_Search (Search, Directory => Path, Pattern => "*", Filter => Search_Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            use Util.Systems.Types;
            use Interfaces.C;
            use Babel.Files;

            Name : constant String    := Simple_Name (Ent);
            Kind : constant File_Kind := Ada.Directories.Kind (Ent);
            File : Babel.Files.File_Type;
            Dir  : Babel.Files.Directory_Type;
            Res  : Integer;
            Fpath : String (1 .. Path'Length + Name'Length + 3);
         begin
            Fpath (Path'Range) := Path;
            Fpath (Path'Last + 1) := '/';
            Fpath (Path'Last + 2 .. Path'Last + 2 + Name'Length - 1) := Name;
            Fpath (Path'Last + 2 + Name'Length) := ASCII.NUL;
            Res := Sys_Stat (Fpath'Address, Stat'Unchecked_Access);
            if (Stat.st_mode and S_IFMT) = S_IFREG then
               if Filter.Is_Accepted (Kind, Path, Name) then
                  File := Into.Find (Name);
                  if File = Babel.Files.NO_FILE then
                     File := Into.Create (Name);
                  end if;
                  Babel.Files.Set_Size (File, Babel.Files.File_Size (Stat.st_size));
                  Babel.Files.Set_Owner (File, Uid_Type (Stat.st_uid), Gid_Type (Stat.st_gid));
                  Babel.Files.Set_Date (File, Stat.st_mtim);
                  Log.Debug ("Adding {0}", Name);
                  Into.Add_File (File);
               end if;
            elsif Name /= "." and Name /= ".." and Filter.Is_Accepted (Kind, Path, Name) then
               Dir := Into.Find (Name);
               if Dir = Babel.Files.NO_DIRECTORY then
                  Dir := Into.Create (Name);
               end if;
               Into.Add_Directory (Dir);
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception ", E);
   end Scan;

   --  ------------------------------
   --  Set the root directory for the local store.
   --  ------------------------------
   procedure Set_Root_Directory (Store : in out Local_Store_Type;
                                 Path  : in String) is
   begin
      Store.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Path);
   end Set_Root_Directory;

   --  ------------------------------
   --  Set the buffer pool to be used by local store.
   --  ------------------------------
   procedure Set_Buffers (Store   : in out Local_Store_Type;
                          Buffers : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Store.Pool := Buffers;
   end Set_Buffers;

end Babel.Stores.Local;

-----------------------------------------------------------------------
--  bkp-stores-local -- Store management for local files
--  Copyright (C) 2014, 2015, 2016 Stephane.Carrez
--  Written by Stephane.Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Directories;
with Ada.Strings.Unbounded;
with Ada.Streams.Stream_IO;
with Interfaces.C.Strings;
with System.OS_Constants;

with Util.Log.Loggers;
with Util.Files;
with Util.Systems.Os;
with Util.Streams.Raw;
with Util.Systems.Types;
with Util.Systems.Os;
with Interfaces;

with Babel.Streams.Files;
package body Babel.Stores.Local is

   function Errno return Integer;
   pragma Import (C, errno, "__get_errno");

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Stores.Local");

   function Get_File_Size (Ent : in Ada.Directories.Directory_Entry_Type) return Babel.Files.File_Size is
      Size : Ada.Directories.File_Size;
   begin
      Size := Ada.Directories.Size (Ent);
      return Babel.Files.File_Size (Size);

   exception
      when Constraint_Error =>
         return Babel.Files.File_Size (Interfaces.Unsigned_32'Last);
   end Get_File_Size;

   --  ------------------------------
   --  Get the absolute path to access the local file.
   --  ------------------------------
   function Get_Absolute_Path (Store : in Local_Store_Type;
                               Path  : in String) return String is
   begin
      if Ada.Strings.Unbounded.Length (Store.Root_Dir) = 0 then
         return Path;
      else
         return Util.Files.Compose (Ada.Strings.Unbounded.To_String (Store.Root_Dir), Path);
      end if;
   end Get_Absolute_Path;

   --  Open a file in the store to read its content with a stream.
   overriding
   procedure Open_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Stream_Access) is
   begin
      null;
   end Open_File;

   --  ------------------------------
   --  Open a file in the store to read its content with a stream.
   --  ------------------------------
   overriding
   procedure Read_File (Store  : in out Local_Store_Type;
                        Path   : in String;
                        Stream : out Babel.Streams.Refs.Stream_Ref) is
      File   : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Buffer : Babel.Files.Buffers.Buffer_Access;
   begin
      Log.Info ("Read file {0}", Path);

      Stream := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      Store.Pool.Get_Buffer (Buffer);
      File.Open (Path, Buffer);
   end Read_File;

   --  ------------------------------
   --  Write a file in the store with a stream.
   --  ------------------------------
   overriding
   procedure Write_File (Store  : in out Local_Store_Type;
                         Path   : in String;
                         Stream : in Babel.Streams.Refs.Stream_Ref;
                         Mode   : in Babel.Files.File_Mode) is
      File   : Babel.Streams.Files.Stream_Access := new Babel.Streams.Files.Stream_Type;
      Output : Babel.Streams.Refs.Stream_Ref;
   begin
      Log.Info ("Write file {0}", Path);

      Output := Babel.Streams.Refs.Stream_Refs.Create (File.all'Access);
      File.Create (Path, Interfaces.C.unsigned (Mode));
      Babel.Streams.Refs.Copy (From => Stream,
                               Into => Output);
   end Write_File;

   procedure Read (Store : in out Local_Store_Type;
                   Path  : in String;
                   Into  : in out Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      File     : Ada.Streams.Stream_IO.File_Type;
      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
   begin
      Ada.Streams.Stream_IO.Open (File, Ada.Streams.Stream_IO.In_File, Abs_Path);
      Ada.Streams.Stream_IO.Read (File, Into.Data, Into.Last);
      Ada.Streams.Stream_IO.Close (File);
      Log.Info ("Read {0} -> {1}", Abs_Path, Ada.Streams.Stream_Element_Offset'Image (Into.Last));
   end Read;

   procedure Open (Store  : in out Local_Store_Type;
                   Stream : in out Util.Streams.Raw.Raw_Stream;
                   Path   : in String) is
      use Util.Systems.Os;
      use type Interfaces.C.int;

      File : Util.Systems.Os.File_Type;
      Name : Util.Systems.Os.Ptr := Interfaces.C.Strings.New_String (Path);
   begin
      File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
      if File < 0 then
         if Errno = System.OS_Constants.ENOENT then
            declare
               Dir : constant String := Ada.Directories.Containing_Directory (Path);
            begin
               Ada.Directories.Create_Path (Dir);
            end;
            File := Util.Systems.Os.Sys_Open (Name, O_CREAT + O_WRONLY, 8#644#);
         end if;
      end if;
      if File < 0 then
         Log.Error ("Cannot create {0}", Path);
         raise Ada.Streams.Stream_IO.Name_Error with "Cannot create " & Path;
      end if;
      Stream.Initialize (File);
      Interfaces.C.Strings.Free (Name);
   end Open;

   procedure Write (Store : in out Local_Store_Type;
                    Path  : in String;
                    Into  : in Babel.Files.Buffers.Buffer) is
      use Ada.Strings.Unbounded;
      use type Ada.Streams.Stream_Element_Offset;

      Abs_Path : constant String := Store.Get_Absolute_Path (Path);
      Stream   : Util.Streams.Raw.Raw_Stream;
   begin
      Log.Info ("Write {0}", Abs_Path);

      Store.Open (Stream, Abs_Path);
      Stream.Write (Into.Data (Into.Data'First .. Into.Last));
      Stream.Close;
   end Write;

   procedure Scan (Store  : in out Local_Store_Type;
                   Path   : in String;
                   Into   : in out Babel.Files.File_Container'Class;
                   Filter : in Babel.Filters.Filter_Type'Class) is
      use Ada.Directories;
      use type Babel.Files.File_Type;
      use type Babel.Files.Directory_Type;

      function Sys_Stat (Path : in System.Address;
                         Stat : access Util.Systems.Types.Stat_Type) return Integer;
      pragma Import (C, Sys_Stat, "stat");

      Search_Filter : constant Ada.Directories.Filter_Type := (Ordinary_File => True,
                                                               Ada.Directories.Directory => True,
                                                               Special_File => False);
      Search   : Search_Type;
      Ent      : Directory_Entry_Type;
      Stat     : aliased Util.Systems.Types.Stat_Type;
   begin
      Log.Info ("Scan directory {0}", Path);

      Start_Search (Search, Directory => Path, Pattern => "*", Filter => Search_Filter);
      while More_Entries (Search) loop
         Get_Next_Entry (Search, Ent);
         declare
            use Util.Systems.Types;
            use Interfaces.C;
            use Babel.Files;

            Name : constant String    := Simple_Name (Ent);
            Kind : constant File_Kind := Ada.Directories.Kind (Ent);
            File : Babel.Files.File_Type;
            Dir  : Babel.Files.Directory_Type;
            Res  : Integer;
            Fpath : String (1 .. Path'Length + Name'Length + 3);
         begin
            Fpath (Path'Range) := Path;
            Fpath (Path'Last + 1) := '/';
            Fpath (Path'Last + 2 .. Path'Last + 2 + Name'Length - 1) := Name;
            Fpath (Path'Last + 2 + Name'Length) := ASCII.NUL;
            Res := Sys_Stat (Fpath'Address, Stat'Unchecked_Access);
            if (Stat.st_mode and S_IFMT) = S_IFREG then
               if Filter.Is_Accepted (Kind, Path, Name) then
                  File := Into.Find (Name);
                  if File = Babel.Files.NO_FILE then
                     File := Into.Create (Name);
                  end if;
                  Babel.Files.Set_Size (File, Babel.Files.File_Size (Stat.st_size));
                  Babel.Files.Set_Owner (File, Uid_Type (Stat.st_uid), Gid_Type (Stat.st_gid));
                  Babel.Files.Set_Date (File, Stat.st_mtim);
                  Log.Debug ("Adding {0}", Name);
                  Into.Add_File (File);
               end if;
            elsif Name /= "." and Name /= ".." and Filter.Is_Accepted (Kind, Path, Name) then
               Dir := Into.Find (Name);
               if Dir = Babel.Files.NO_DIRECTORY then
                  Dir := Into.Create (Name);
               end if;
               Into.Add_Directory (Dir);
            end if;
         end;
      end loop;

   exception
      when E : others =>
         Log.Error ("Exception ", E);
   end Scan;

   --  ------------------------------
   --  Set the root directory for the local store.
   --  ------------------------------
   procedure Set_Root_Directory (Store : in out Local_Store_Type;
                                 Path  : in String) is
   begin
      Store.Root_Dir := Ada.Strings.Unbounded.To_Unbounded_String (Path);
   end Set_Root_Directory;

   --  ------------------------------
   --  Set the buffer pool to be used by local store.
   --  ------------------------------
   procedure Set_Buffers (Store   : in out Local_Store_Type;
                          Buffers : in Babel.Files.Buffers.Buffer_Pool_Access) is
   begin
      Store.Pool := Buffers;
   end Set_Buffers;

end Babel.Stores.Local;

Change Write_File to use the Babel.Files.File_Mode type


------------------------------------------------------------------------------
-- Copyright (c) 2016, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.Smaz_Generic is

   use type Ada.Streams.Stream_Element_Offset;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural);
      --  Try to find the longest entry in Dict that is a prefix of Template,
      --  setting Length to 0 when no such entry exists.

   function Verbatim_Size
     (Dict : in Dictionary;
      Length : in Positive)
     return Ada.Streams.Stream_Element_Count
   is (Verbatim_Size (Length, Dict.Last_Code, Dict.Variable_Length_Verbatim));
      --  Wrapper around the formal Verbatim_Size

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural)
   is
      N : Natural;
      Is_Valid : Boolean;
   begin
      Length := 0;

      for Last in reverse Template'Range loop
         Is_Valid := False;
         N := Dict.Hash (Template (Template'First .. Last));

         To_Code :
         begin
            Code := Dictionary_Code'Val (N);
            if Is_Valid_Code (Dict, Code) then
               Is_Valid := True;
            end if;
         exception
            when Constraint_Error => null;
         end To_Code;

         if Is_Valid
           and then Template (Template'First .. Last)
              = Dict.Values (Code_First (Dict.Offsets, Code, Dict.Values'First)
                          .. Code_Last (Dict.Offsets, Code, Dict.Values'Last))
         then
            Length := 1 + Last - Template'First;
            return;
         end if;
      end loop;
   end Find_Entry;

   ----------------------
   -- Public Interface --
   ----------------------

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count is
   begin
      return Verbatim_Size
        (Input'Length, Dict.Last_Code, Dict.Variable_Length_Verbatim);
   end Compressed_Upper_Bound;

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset)
   is
      procedure Find_Current_Entry;

      Input_Index : Positive := Input'First;
      Length : Natural;
      Code : Dictionary_Code;
      Output_Index : Ada.Streams.Stream_Element_Offset;

      procedure Find_Current_Entry is
      begin
         Find_Entry
           (Dict,
            Input (Input_Index
                   .. Natural'Min (Input_Index + Dict.Max_Word_Length - 1,
                                   Input'Last)),
            Code,
            Length);
      end Find_Current_Entry;

      Previous_Verbatim_Beginning : Natural := 0;
      Previous_Verbatim_Index : Ada.Streams.Stream_Element_Offset := 0;
   begin
      Output_Index := Output_Buffer'First;
      Find_Current_Entry;

      Main_Loop :
      while Input_Index in Input'Range loop
         Data_In_Dict :
         while Length > 0 loop
            Write_Code (Output_Buffer, Output_Index, Code);
            Input_Index := Input_Index + Length;
            exit Main_Loop when Input_Index not in Input'Range;
            Find_Current_Entry;
         end loop Data_In_Dict;

         Verbatim_Block :
         declare
            Beginning : Positive := Input_Index;
            Verbatim_Length : Natural;
         begin
            Verbatim_Scan :
            while Length = 0 and Input_Index in Input'Range loop
               Input_Index := Input_Index + 1;
               Find_Current_Entry;
            end loop Verbatim_Scan;

            Verbatim_Length := Input_Index - Beginning;

            if Previous_Verbatim_Beginning > 0
              and then Output_Index + Verbatim_Size (Dict, Verbatim_Length)
                 >= Previous_Verbatim_Index + Verbatim_Size
                    (Dict, Input_Index - Previous_Verbatim_Beginning)
            then
               Beginning := Previous_Verbatim_Beginning;
               Output_Index := Previous_Verbatim_Index;
               Verbatim_Length := Input_Index - Beginning;
            else
               Previous_Verbatim_Beginning := Beginning;
               Previous_Verbatim_Index := Output_Index;
            end if;

            Write_Verbatim
              (Output_Buffer, Output_Index,
               Input (Beginning .. Input_Index - 1),
               Dict.Last_Code, Dict.Variable_Length_Verbatim);
         end Verbatim_Block;
      end loop Main_Loop;

      Output_Last := Output_Index - 1;
   end Compress;

   function Compress (Dict : in Dictionary; Input : in String)
     return Ada.Streams.Stream_Element_Array
   is
      Result : Ada.Streams.Stream_Element_Array
        (1 .. Compressed_Upper_Bound (Dict, Input));
      Last : Ada.Streams.Stream_Element_Offset;
   begin
      Compress (Dict, Input, Result, Last);
      return Result (Result'First .. Last);
   end Compress;

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural
   is
      Result : Natural := 0;
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Skip_Verbatim (Input, Input_Index, Verbatim_Length);
            Result := Result + Verbatim_Length;
         else
            Result := Result + Dict_Entry_Length (Dict, Code);
         end if;
      end loop;

      return Result;
   end Decompressed_Length;

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural)
   is
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      Output_Last := Output_Buffer'First - 1;

      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Read_Verbatim
              (Input, Input_Index,
               Output_Buffer
                 (Output_Last + 1 .. Output_Last + Verbatim_Length));
            Output_Last := Output_Last + Verbatim_Length;
         else
            declare
               Decoded : constant String := Dict_Entry (Dict, Code);
            begin
               Output_Buffer (Output_Last + 1 .. Output_Last + Decoded'Length)
                 := Decoded;
               Output_Last := Output_Last + Decoded'Length;
            end;
         end if;
      end loop;
   end Decompress;

   function Decompress
     (Dict : in Dictionary; Input : in Ada.Streams.Stream_Element_Array)
     return String
   is
      Result : String (1 .. Decompressed_Length (Dict, Input));
      Last : Natural;
   begin
      Decompress (Dict, Input, Result, Last);
      pragma Assert (Last = Result'Last);
      return Result;
   end Decompress;

end Natools.Smaz_Generic;

------------------------------------------------------------------------------
-- Copyright (c) 2016, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.Smaz_Generic is

   use type Ada.Streams.Stream_Element_Offset;

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural);
      --  Try to find the longest entry in Dict that is a prefix of Template,
      --  setting Length to 0 when no such entry exists.

   function Verbatim_Size
     (Dict : in Dictionary;
      Length : in Positive)
     return Ada.Streams.Stream_Element_Count
   is (Verbatim_Size (Length, Dict.Last_Code, Dict.Variable_Length_Verbatim));
      --  Wrapper around the formal Verbatim_Size

   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Find_Entry
     (Dict : in Dictionary;
      Template : in String;
      Code : out Dictionary_Code;
      Length : out Natural)
   is
      N : Natural;
      Is_Valid : Boolean;
   begin
      Length := 0;

      for Last in reverse Template'Range loop
         Is_Valid := False;
         N := Dict.Hash (Template (Template'First .. Last));

         To_Code :
         begin
            Code := Dictionary_Code'Val (N);
            if Is_Valid_Code (Dict, Code) then
               Is_Valid := True;
            end if;
         exception
            when Constraint_Error => null;
         end To_Code;

         if Is_Valid
           and then Template (Template'First .. Last)
              = Dict.Values (Code_First (Dict.Offsets, Code, Dict.Values'First)
                          .. Code_Last (Dict.Offsets, Code, Dict.Values'Last))
         then
            Length := 1 + Last - Template'First;
            return;
         end if;
      end loop;
   end Find_Entry;

   ----------------------
   -- Public Interface --
   ----------------------

   function Compressed_Upper_Bound
     (Dict : in Dictionary;
      Input : in String)
     return Ada.Streams.Stream_Element_Count is
   begin
      return Verbatim_Size
        (Input'Length, Dict.Last_Code, Dict.Variable_Length_Verbatim);
   end Compressed_Upper_Bound;

   procedure Compress
     (Dict : in Dictionary;
      Input : in String;
      Output_Buffer : out Ada.Streams.Stream_Element_Array;
      Output_Last : out Ada.Streams.Stream_Element_Offset)
   is
      procedure Find_Current_Entry;

      Input_Index : Positive := Input'First;
      Length : Natural;
      Code : Dictionary_Code;
      Output_Index : Ada.Streams.Stream_Element_Offset;

      procedure Find_Current_Entry is
      begin
         Find_Entry
           (Dict,
            Input (Input_Index
                   .. Natural'Min (Input_Index + Dict.Max_Word_Length - 1,
                                   Input'Last)),
            Code,
            Length);
      end Find_Current_Entry;

      Previous_Verbatim_Beginning : Natural := 0;
      Previous_Verbatim_Index : Ada.Streams.Stream_Element_Offset := 0;
   begin
      Output_Index := Output_Buffer'First;
      Find_Current_Entry;

      Main_Loop :
      while Input_Index in Input'Range loop
         Data_In_Dict :
         while Length > 0 loop
            Write_Code (Output_Buffer, Output_Index, Code);
            Input_Index := Input_Index + Length;
            exit Main_Loop when Input_Index not in Input'Range;
            Find_Current_Entry;
         end loop Data_In_Dict;

         Verbatim_Block :
         declare
            Beginning : Positive := Input_Index;
            Verbatim_Length : Natural;
         begin
            Verbatim_Scan :
            while Length = 0 and Input_Index in Input'Range loop
               Input_Index := Input_Index + 1;
               Find_Current_Entry;
            end loop Verbatim_Scan;

            Verbatim_Length := Input_Index - Beginning;

            if Previous_Verbatim_Beginning > 0
              and then Output_Index + Verbatim_Size (Dict, Verbatim_Length)
                 >= Previous_Verbatim_Index + Verbatim_Size
                    (Dict, Input_Index - Previous_Verbatim_Beginning)
            then
               Beginning := Previous_Verbatim_Beginning;
               Output_Index := Previous_Verbatim_Index;
               Verbatim_Length := Input_Index - Beginning;
            else
               Previous_Verbatim_Beginning := Beginning;
               Previous_Verbatim_Index := Output_Index;
            end if;

            Write_Verbatim
              (Output_Buffer, Output_Index,
               Input (Beginning .. Input_Index - 1),
               Dict.Last_Code, Dict.Variable_Length_Verbatim);
         end Verbatim_Block;
      end loop Main_Loop;

      Output_Last := Output_Index - 1;
   end Compress;

   function Compress (Dict : in Dictionary; Input : in String)
     return Ada.Streams.Stream_Element_Array
   is
      Result : Ada.Streams.Stream_Element_Array
        (1 .. Compressed_Upper_Bound (Dict, Input));
      Last : Ada.Streams.Stream_Element_Offset;
   begin
      Compress (Dict, Input, Result, Last);
      return Result (Result'First .. Last);
   end Compress;

   function Decompressed_Length
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array)
     return Natural
   is
      Result : Natural := 0;
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Skip_Verbatim (Input, Input_Index, Verbatim_Length);
            Result := Result + Verbatim_Length;
         else
            exit when not Is_Valid_Code (Dict, Code);
            Result := Result + Dict_Entry_Length (Dict, Code);
         end if;
      end loop;

      return Result;
   end Decompressed_Length;

   procedure Decompress
     (Dict : in Dictionary;
      Input : in Ada.Streams.Stream_Element_Array;
      Output_Buffer : out String;
      Output_Last : out Natural)
   is
      Input_Index : Ada.Streams.Stream_Element_Offset := Input'First;
      Code : Dictionary_Code;
      Verbatim_Length : Natural;
   begin
      Output_Last := Output_Buffer'First - 1;

      while Input_Index in Input'Range loop
         Read_Code
           (Input, Input_Index,
            Code, Verbatim_Length,
            Dict.Last_Code, Dict.Variable_Length_Verbatim);

         if Verbatim_Length > 0 then
            Read_Verbatim
              (Input, Input_Index,
               Output_Buffer
                 (Output_Last + 1 .. Output_Last + Verbatim_Length));
            Output_Last := Output_Last + Verbatim_Length;
         else
            exit when not Is_Valid_Code (Dict, Code);

            declare
               Decoded : constant String := Dict_Entry (Dict, Code);
            begin
               Output_Buffer (Output_Last + 1 .. Output_Last + Decoded'Length)
                 := Decoded;
               Output_Last := Output_Last + Decoded'Length;
            end;
         end if;
      end loop;
   end Decompress;

   function Decompress
     (Dict : in Dictionary; Input : in Ada.Streams.Stream_Element_Array)
     return String
   is
      Result : String (1 .. Decompressed_Length (Dict, Input));
      Last : Natural;
   begin
      Decompress (Dict, Input, Result, Last);
      pragma Assert (Last = Result'Last);
      return Result;
   end Decompress;

end Natools.Smaz_Generic;

smaz_generic: update semantics of Read_Code to signal end-of-input


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

package body Wiki.Filters is

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   procedure Add_Node (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
   begin
      if Filter.Next /= null then
         Filter.Add_Node (Document, Kind);
      else
         Wiki.Nodes.Append (Document, Kind);
      end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   procedure Add_Text (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Nodes.Format_Map) is
   begin
      if Filter.Next /= null then
         Filter.Add_Text (Document, Text, Format);
      else
         Wiki.Nodes.Append (Document, Text, Format);
      end if;
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   procedure Add_Header (Filter    : in out Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      if Filter.Next /= null then
         Filter.Add_Header (Document, Header, Level);
      else
         Wiki.Nodes.Append (Document, Header, Level);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   procedure Push_Node (Filter     : in out Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Tag        : in Wiki.Nodes.Html_Tag_Type;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type) is
   begin
      if Filter.Next /= null then
         Filter.Push_Node (Document, Tag, Attributes);
      else
         Wiki.Nodes.Append (Document, Tag, Attributes);
      end if;
   end Push_Node;

   --  ------------------------------
   --  Pop a HTML node with the given tag.
   --  ------------------------------
   procedure Pop_Node (Filter   : in out Filter_Type;
                       Document : in out Wiki.Nodes.Document;
                       Tag     : in Wiki.Nodes.Html_Tag_Type) is
   begin
      if Filter.Next /= null then
         Filter.Pop_Node (Document, Tag);
      else
         Wiki.Nodes.Append (Document, Tag);
      end if;
   end Pop_Node;

   --  ------------------------------
   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   overriding
   procedure Add_Blockquote (Document : in out Filter_Type;
                             Level    : in Natural) is
   begin
      Document.Document.Add_Blockquote (Level);
   end Add_Blockquote;

   --  ------------------------------
   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   --  ------------------------------
   overriding
   procedure Add_List_Item (Document : in out Filter_Type;
                            Level    : in Positive;
                            Ordered  : in Boolean) is
   begin
      Document.Document.Add_List_Item (Level, Ordered);
   end Add_List_Item;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Document : in out Filter_Type;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Link (Name, Link, Language, Title);
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Document    : in out Filter_Type;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Image (Link, Alt, Position, Description);
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   overriding
   procedure Add_Quote (Document : in out Filter_Type;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Quote (Quote, Link, Language);
   end Add_Quote;

   --  ------------------------------
   --  Add a text block that is pre-formatted.
   --  ------------------------------
   overriding
   procedure Add_Preformatted (Document : in out Filter_Type;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Preformatted (Text, Format);
   end Add_Preformatted;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Document : in out Filter_Type) is
   begin
      Document.Document.Finish;
   end Finish;

end Wiki.Filters;

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

package body Wiki.Filters is

   --  ------------------------------
   --  Add a simple node such as N_LINE_BREAK, N_HORIZONTAL_RULE or N_PARAGRAPH to the document.
   --  ------------------------------
   procedure Add_Node (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Kind      : in Wiki.Nodes.Simple_Node_Kind) is
   begin
      if Filter.Next /= null then
         Filter.Add_Node (Document, Kind);
      else
         Wiki.Nodes.Append (Document, Kind);
      end if;
   end Add_Node;

   --  ------------------------------
   --  Add a text content with the given format to the document.
   --  ------------------------------
   procedure Add_Text (Filter    : in out Filter_Type;
                       Document  : in out Wiki.Nodes.Document;
                       Text      : in Wiki.Strings.WString;
                       Format    : in Wiki.Nodes.Format_Map) is
   begin
      if Filter.Next /= null then
         Filter.Add_Text (Document, Text, Format);
      else
         Wiki.Nodes.Append (Document, Text, Format);
      end if;
   end Add_Text;

   --  ------------------------------
   --  Add a section header with the given level in the document.
   --  ------------------------------
   procedure Add_Header (Filter    : in out Filter_Type;
                         Document  : in out Wiki.Nodes.Document;
                         Header    : in Wiki.Strings.WString;
                         Level     : in Natural) is
   begin
      if Filter.Next /= null then
         Filter.Add_Header (Document, Header, Level);
      else
         Wiki.Nodes.Append (Document, Header, Level);
      end if;
   end Add_Header;

   --  ------------------------------
   --  Push a HTML node with the given tag to the document.
   --  ------------------------------
   procedure Push_Node (Filter     : in out Filter_Type;
                        Document   : in out Wiki.Nodes.Document;
                        Tag        : in Wiki.Nodes.Html_Tag_Type;
                        Attributes : in out Wiki.Attributes.Attribute_List_Type) is
   begin
      if Filter.Next /= null then
         Filter.Push_Node (Document, Tag, Attributes);
      else
         Wiki.Nodes.Push_Node (Document, Tag, Attributes);
      end if;
   end Push_Node;

   --  ------------------------------
   --  Pop a HTML node with the given tag.
   --  ------------------------------
   procedure Pop_Node (Filter   : in out Filter_Type;
                       Document : in out Wiki.Nodes.Document;
                       Tag     : in Wiki.Nodes.Html_Tag_Type) is
   begin
      if Filter.Next /= null then
         Filter.Pop_Node (Document, Tag);
      else
         Wiki.Nodes.Pop_Node (Document, Tag);
      end if;
   end Pop_Node;

   --  ------------------------------
   --  Add a blockquote (<blockquote>).  The level indicates the blockquote nested level.
   --  The blockquote must be closed at the next header.
   --  ------------------------------
   overriding
   procedure Add_Blockquote (Document : in out Filter_Type;
                             Level    : in Natural) is
   begin
      Document.Document.Add_Blockquote (Level);
   end Add_Blockquote;

   --  ------------------------------
   --  Add a list item (<li>).  Close the previous paragraph and list item if any.
   --  The list item will be closed at the next list item, next paragraph or next header.
   --  ------------------------------
   overriding
   procedure Add_List_Item (Document : in out Filter_Type;
                            Level    : in Positive;
                            Ordered  : in Boolean) is
   begin
      Document.Document.Add_List_Item (Level, Ordered);
   end Add_List_Item;

   --  ------------------------------
   --  Add a link.
   --  ------------------------------
   overriding
   procedure Add_Link (Document : in out Filter_Type;
                       Name     : in Unbounded_Wide_Wide_String;
                       Link     : in Unbounded_Wide_Wide_String;
                       Language : in Unbounded_Wide_Wide_String;
                       Title    : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Link (Name, Link, Language, Title);
   end Add_Link;

   --  ------------------------------
   --  Add an image.
   --  ------------------------------
   overriding
   procedure Add_Image (Document    : in out Filter_Type;
                        Link        : in Unbounded_Wide_Wide_String;
                        Alt         : in Unbounded_Wide_Wide_String;
                        Position    : in Unbounded_Wide_Wide_String;
                        Description : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Image (Link, Alt, Position, Description);
   end Add_Image;

   --  ------------------------------
   --  Add a quote.
   --  ------------------------------
   overriding
   procedure Add_Quote (Document : in out Filter_Type;
                        Quote    : in Unbounded_Wide_Wide_String;
                        Link     : in Unbounded_Wide_Wide_String;
                        Language : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Quote (Quote, Link, Language);
   end Add_Quote;

   --  ------------------------------
   --  Add a text block that is pre-formatted.
   --  ------------------------------
   overriding
   procedure Add_Preformatted (Document : in out Filter_Type;
                               Text     : in Unbounded_Wide_Wide_String;
                               Format   : in Unbounded_Wide_Wide_String) is
   begin
      Document.Document.Add_Preformatted (Text, Format);
   end Add_Preformatted;

   --  ------------------------------
   --  Finish the document after complete wiki text has been parsed.
   --  ------------------------------
   overriding
   procedure Finish (Document : in out Filter_Type) is
   begin
      Document.Document.Finish;
   end Finish;

end Wiki.Filters;

Use Push_Node and Pop_Node for the HTML tag management