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

with Ada.Calendar;

with AWA.Users.Models;
with AWA.Modules.Beans;
with AWA.Permissions.Services;

with ADO.SQL;
with Util.Log.Loggers;
with AWA.Users.Modules;
with AWA.Workspaces.Beans;
package body AWA.Workspaces.Modules is

   package ASC renames AWA.Services.Contexts;

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

   package Register is new AWA.Modules.Beans (Module => Workspace_Module,
                                              Module_Access => Workspace_Module_Access);

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

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Workspaces_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Workspaces_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Member_List_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Member_List_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Invitation_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Invitation_Bean'Access);

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

      Plugin.User_Manager := AWA.Users.Modules.Get_User_Manager;
      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   --  ------------------------------
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref) is
      User    : constant AWA.Users.Models.User_Ref := Context.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         Workspace := AWA.Workspaces.Models.Null_Workspace;
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (Session, Query, Found);
      if Found then
         Workspace := WS;
         return;
      end if;

      --  Create a workspace for this user.
      WS.Set_Owner (User);
      WS.Set_Create_Date (Ada.Calendar.Clock);
      WS.Save (Session);

      --  And give full control of the workspace for this user
      AWA.Permissions.Services.Add_Permission (Session => Session,
                                               User    => User.Get_Id,
                                               Entity  => WS);

      Workspace := WS;
   end Get_Workspace;

   --  ------------------------------
   --  Load the invitation from the access key and verify that the key is still valid.
   --  ------------------------------
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is
      use type Ada.Calendar.Time;

      Ctx    : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query  : ADO.SQL.Query;
      DB_Key : AWA.Users.Models.Access_Key_Ref;
      Found  : Boolean;
   begin
      Log.Debug ("Loading invitation from key {0}", Key);

      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist");
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Ada.Calendar.Clock then
         Log.Info ("Invitation key {0} has expired");
         raise Not_Found;
      end if;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", DB_Key.Get_User.Get_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn");
         raise Not_Found;
      end if;
   end Load_Invitation;

   --  ------------------------------
   --  Accept the invitation identified by the access key.
   --  ------------------------------
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String) is
      use type Ada.Calendar.Time;

      Ctx     : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query   : ADO.SQL.Query;
      DB_Key  : AWA.Users.Models.Access_Key_Ref;
      Found   : Boolean;
      Invitation : AWA.Workspaces.Models.Invitation_Ref;
   begin
      Log.Debug ("Accept invitation with key {0}", Key);
      Ctx.Start;
      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist");
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Ada.Calendar.Clock then
         Log.Info ("Invitation key {0} has expired");
         raise Not_Found;
      end if;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", DB_Key.Get_User.Get_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn");
         raise Not_Found;
      end if;
      DB_Key.Delete (DB);
      Invitation.Set_Acceptance_Date (ADO.Nullable_Time '(Is_Null => False,
                                                          Value => Ada.Calendar.Clock));
      Invitation.Save (DB);
      Ctx.Commit;
   end Accept_Invitation;

   --  ------------------------------
   --  Send the invitation to the user.
   --  ------------------------------
   procedure Send_Invitation (Module     : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is
      Ctx     : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : AWA.Users.Models.Email_Ref;
      Invitee : AWA.Users.Models.User_Ref;
   begin
      Log.Info ("Sending invitation to {0}", String '(Invitation.Get_Email));

      Ctx.Start;
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (DB, Query, Found);
      if not Found then
         return;
      end if;

      Query.Clear;
      Query.Set_Filter ("o.email = ?");
      Query.Add_Param (String '(Invitation.Get_Email));
      Email.Find (DB, Query, Found);
      if not Found then
         Email.Set_User_Id (0);
         Email.Set_Email (String '(Invitation.Get_Email));
         Email.Save (DB);
         Invitee.Set_Email (Email);
         Invitee.Set_Name (String '(Invitation.Get_Email));
         Invitee.Save (DB);
         Email.Set_User_Id (Invitee.Get_Id);
         Email.Save (DB);
      else
         Invitee.Load (DB, Email.Get_User_Id);
      end if;
      Key := AWA.Users.Models.Access_Key_Ref (Invitation.Get_Access_Key);
      Module.User_Manager.Create_Access_Key (Invitee, Key, 365 * 86400.0, DB);
      Key.Save (DB);
      Invitation.Set_Access_Key (Key);
      Invitation.Set_Inviter (User);
      Invitation.Set_Invitee (Invitee);
      Invitation.Set_Workspace (WS);
      Invitation.Set_Create_Date (Ada.Calendar.Clock);
      Invitation.Save (DB);
      Ctx.Commit;
   end Send_Invitation;

end AWA.Workspaces.Modules;

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

with Ada.Calendar;

with AWA.Users.Models;
with AWA.Modules.Beans;
with AWA.Permissions.Services;

with ADO.SQL;
with Util.Log.Loggers;
with AWA.Users.Modules;
with AWA.Workspaces.Beans;
package body AWA.Workspaces.Modules is

   package ASC renames AWA.Services.Contexts;

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

   package Register is new AWA.Modules.Beans (Module => Workspace_Module,
                                              Module_Access => Workspace_Module_Access);

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

      --  Register here any bean class, servlet, filter.
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Workspaces_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Workspaces_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Member_List_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Member_List_Bean'Access);
      Register.Register (Plugin => Plugin,
                         Name   => "AWA.Workspaces.Beans.Invitation_Bean",
                         Handler => AWA.Workspaces.Beans.Create_Invitation_Bean'Access);

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

      Plugin.User_Manager := AWA.Users.Modules.Get_User_Manager;
      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the current workspace associated with the current user.
   --  If the user has not workspace, create one.
   --  ------------------------------
   procedure Get_Workspace (Session   : in out ADO.Sessions.Master_Session;
                            Context   : in AWA.Services.Contexts.Service_Context_Access;
                            Workspace : out AWA.Workspaces.Models.Workspace_Ref) is
      User    : constant AWA.Users.Models.User_Ref := Context.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         Workspace := AWA.Workspaces.Models.Null_Workspace;
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (Session, Query, Found);
      if Found then
         Workspace := WS;
         return;
      end if;

      --  Create a workspace for this user.
      WS.Set_Owner (User);
      WS.Set_Create_Date (Ada.Calendar.Clock);
      WS.Save (Session);

      --  And give full control of the workspace for this user
      AWA.Permissions.Services.Add_Permission (Session => Session,
                                               User    => User.Get_Id,
                                               Entity  => WS);

      Workspace := WS;
   end Get_Workspace;

   --  ------------------------------
   --  Load the invitation from the access key and verify that the key is still valid.
   --  ------------------------------
   procedure Load_Invitation (Module     : in Workspace_Module;
                              Key        : in String;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is
      use type Ada.Calendar.Time;

      Ctx    : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB     : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query  : ADO.SQL.Query;
      DB_Key : AWA.Users.Models.Access_Key_Ref;
      Found  : Boolean;
   begin
      Log.Debug ("Loading invitation from key {0}", Key);

      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist");
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Ada.Calendar.Clock then
         Log.Info ("Invitation key {0} has expired");
         raise Not_Found;
      end if;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", DB_Key.Get_User.Get_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn");
         raise Not_Found;
      end if;
   end Load_Invitation;

   --  ------------------------------
   --  Accept the invitation identified by the access key.
   --  ------------------------------
   procedure Accept_Invitation (Module     : in Workspace_Module;
                                Key        : in String) is
      use type Ada.Calendar.Time;

      Ctx     : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      Query   : ADO.SQL.Query;
      DB_Key  : AWA.Users.Models.Access_Key_Ref;
      Found   : Boolean;
      Invitation : AWA.Workspaces.Models.Invitation_Ref;
   begin
      Log.Debug ("Accept invitation with key {0}", Key);
      Ctx.Start;
      Query.Set_Filter ("o.access_key = :key");
      Query.Bind_Param ("key", Key);
      DB_Key.Find (DB, Query, Found);
      if not Found then
         Log.Info ("Invitation key {0} does not exist");
         raise Not_Found;
      end if;
      if DB_Key.Get_Expire_Date < Ada.Calendar.Clock then
         Log.Info ("Invitation key {0} has expired");
         raise Not_Found;
      end if;
      Query.Set_Filter ("o.invitee_id = :user");
      Query.Bind_Param ("user", DB_Key.Get_User.Get_Id);
      Invitation.Find (DB, Query, Found);
      if not Found then
         Log.Warn ("Invitation key {0} has been withdawn");
         raise Not_Found;
      end if;
      DB_Key.Delete (DB);
      Invitation.Set_Acceptance_Date (ADO.Nullable_Time '(Is_Null => False,
                                                          Value => Ada.Calendar.Clock));
      Invitation.Save (DB);
      Ctx.Commit;
   end Accept_Invitation;

   --  ------------------------------
   --  Send the invitation to the user.
   --  ------------------------------
   procedure Send_Invitation (Module     : in Workspace_Module;
                              Invitation : in out AWA.Workspaces.Models.Invitation_Ref'Class) is
      use type ADO.Identifier;

      Ctx     : constant ASC.Service_Context_Access := AWA.Services.Contexts.Current;
      DB      : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      User    : constant AWA.Users.Models.User_Ref := Ctx.Get_User;
      WS      : AWA.Workspaces.Models.Workspace_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
      Key     : AWA.Users.Models.Access_Key_Ref;
      Email   : AWA.Users.Models.Email_Ref;
      Invitee : AWA.Users.Models.User_Ref;
      Invit   : AWA.Workspaces.Models.Invitation_Ref;
   begin
      Log.Info ("Sending invitation to {0}", String '(Invitation.Get_Email));

      Ctx.Start;
      if User.Is_Null then
         Log.Error ("There is no current user.  The workspace cannot be identified");
         return;
      end if;

      --  Find the workspace associated with the current user.
      Query.Add_Param (User.Get_Id);
      Query.Set_Filter ("o.owner_id = ?");
      WS.Find (DB, Query, Found);
      if not Found then
         return;
      end if;

      Query.Clear;
      Query.Set_Filter ("o.email = ?");
      Query.Add_Param (String '(Invitation.Get_Email));
      Email.Find (DB, Query, Found);
      if not Found then
         Email.Set_User_Id (0);
         Email.Set_Email (String '(Invitation.Get_Email));
         Email.Save (DB);
         Invitee.Set_Email (Email);
         Invitee.Set_Name (String '(Invitation.Get_Email));
         Invitee.Save (DB);
         Email.Set_User_Id (Invitee.Get_Id);
         Email.Save (DB);
      else
         Invitee.Load (DB, Email.Get_User_Id);
      end if;

      --  Check for a previous invitation for the user and delete it.
      Query.Clear;
      Query.Set_Filter ("o.invitee_id = ? AND o.workspace_id = ?");
      Query.Add_Param (Invitee.Get_Id);
      Query.Add_Param (WS.Get_Id);
      Invit.Find (DB, Query, Found);
      if Found then
         Key := AWA.Users.Models.Access_Key_Ref (Invit.Get_Access_Key);
         Key.Delete (DB);
         if not Invitation.Is_Inserted or else Invit.Get_Id /= Invitation.Get_Id then
            Invit.Delete (DB);
         end if;
      end if;
      Key := AWA.Users.Models.Access_Key_Ref (Invitation.Get_Access_Key);
      Module.User_Manager.Create_Access_Key (Invitee, Key, 365 * 86400.0, DB);
      Key.Save (DB);
      Invitation.Set_Access_Key (Key);
      Invitation.Set_Inviter (User);
      Invitation.Set_Invitee (Invitee);
      Invitation.Set_Workspace (WS);
      Invitation.Set_Create_Date (Ada.Calendar.Clock);
      Invitation.Save (DB);
      Ctx.Commit;
   end Send_Invitation;

end AWA.Workspaces.Modules;

Remove a previous invitation to the same user/workspace pair


--------------------------------------------------------------------------------
-- Copyright (c) 2012, Felix Krause <contact@flyx.org>
--
-- Permission to use, copy, modify, and/or 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.
--------------------------------------------------------------------------------

private with GL.Low_Level;

package GL.Toggles is
   pragma Preelaborate;

   type Toggle_State is (Disabled, Enabled);

   type Toggle is (Point_Smooth, Line_Smooth, Line_Stipple, Polygon_Smooth, Polygon_Stipple,
                   Cull_Face, Lighting, Color_Material,
                   Fog, Depth_Test, Stencil_Test, Normalize, Alpha_Test, Dither,
                   Blend, Index_Logic_Op, Color_Logic_Op, Scissor_Test, Texture_Gen_S,
                   Texture_Gen_T, Texture_Gen_R, Texture_Gen_Q,
                   Auto_Normal,
                   Map1_Color_4, Map1_Index,
                   Map1_Normal, Map1_Texture_Coord_1, Map1_Texture_Coord_2,
                   Map1_Texture_Coord_3, Map1_Texture_Coord_4,
                   Map1_Vertex_3, Map1_Vertex_4, Map2_Color_4, Map2_Index,
                   Map2_Normal, Map2_Texture_Coord_1, Map2_Texture_Coord_2,
                   Map2_Texture_Coord_3, Map2_Texture_Coord_4, Map2_Vertex_3,
                   Map2_Vertex_4, Texture_1D, Texture_2D, Polygon_Offset_Point, Polygon_Offset_Line,
                   Clip_Plane_0, Clip_Plane_1,
                   Clip_Plane_2, Clip_Plane_3, Clip_Plane_4, Clip_Plane_5,
                   Light0, Light1, Light2, Light3, Light4, Light5, Light6, Light7,
                   Convolution_1D, Convolution_2D, Separable_2D, Histogram,
                   Minmax, Polygon_Offset_Fill, Rescale_Normal, Texture_3D, Multisample,
                   Sample_Alpha_To_Coverage, Sample_Alpha_To_One,
                   Sample_Coverage, Color_Table, Post_Convolution_Color_Table,
                   Post_Color_Matrix_Color_Table, Color_Sum, Texture_Cube_Map,
                   Vertex_Program_Point_Size, Vertex_Program_Two_Side, Point_Sprite,
                   Rasterizer_Discard);

   procedure Enable (Subject : Toggle);
   procedure Disable (Subject : Toggle);
   procedure Set (Subject : Toggle; Value : Toggle_State);
   function State (Subject : Toggle) return Toggle_State;
private
   for Toggle use (Point_Smooth             => 16#0B10#,
                   Line_Smooth              => 16#0B20#,
                   Line_Stipple             => 16#0B24#,
                   Polygon_Smooth           => 16#0B41#,
                   Polygon_Stipple          => 16#0B42#,
                   Cull_Face                => 16#0B44#,
                   Lighting                 => 16#0B50#,
                   Color_Material           => 16#0B57#,
                   Fog                      => 16#0B60#,
                   Depth_Test               => 16#0B71#,
                   Stencil_Test             => 16#0B90#,
                   Normalize                => 16#0BA1#,
                   Alpha_Test               => 16#0BC0#,
                   Dither                   => 16#0BD0#,
                   Blend                    => 16#0BE2#,
                   Index_Logic_Op           => 16#0BF1#,
                   Color_Logic_Op           => 16#0BF2#,
                   Scissor_Test             => 16#0C11#,
                   Texture_Gen_S            => 16#0C60#,
                   Texture_Gen_T            => 16#0C61#,
                   Texture_Gen_R            => 16#0C62#,
                   Texture_Gen_Q            => 16#0C63#,
                   Auto_Normal              => 16#0D80#,
                   Map1_Color_4             => 16#0D90#,
                   Map1_Index               => 16#0D91#,
                   Map1_Normal              => 16#0D92#,
                   Map1_Texture_Coord_1     => 16#0D93#,
                   Map1_Texture_Coord_2     => 16#0D94#,
                   Map1_Texture_Coord_3     => 16#0D95#,
                   Map1_Texture_Coord_4     => 16#0D96#,
                   Map1_Vertex_3            => 16#0D97#,
                   Map1_Vertex_4            => 16#0D98#,
                   Map2_Color_4             => 16#0DB0#,
                   Map2_Index               => 16#0DB1#,
                   Map2_Normal              => 16#0DB2#,
                   Map2_Texture_Coord_1     => 16#0DB3#,
                   Map2_Texture_Coord_2     => 16#0DB4#,
                   Map2_Texture_Coord_3     => 16#0DB5#,
                   Map2_Texture_Coord_4     => 16#0DB6#,
                   Map2_Vertex_3            => 16#0DB7#,
                   Map2_Vertex_4            => 16#0DB8#,
                   Texture_1D               => 16#0DE0#,
                   Texture_2D               => 16#0DE1#,
                   Polygon_Offset_Point     => 16#2A01#,
                   Polygon_Offset_Line      => 16#2A02#,
                   Clip_Plane_0             => 16#3000#,
                   Clip_Plane_1             => 16#3001#,
                   Clip_Plane_2             => 16#3002#,
                   Clip_Plane_3             => 16#3003#,
                   Clip_Plane_4             => 16#3004#,
                   Clip_Plane_5             => 16#3005#,
                   Light0                   => 16#4000#,
                   Light1                   => 16#4001#,
                   Light2                   => 16#4002#,
                   Light3                   => 16#4003#,
                   Light4                   => 16#4004#,
                   Light5                   => 16#4005#,
                   Light6                   => 16#4006#,
                   Light7                   => 16#4007#,
                   Convolution_1D           => 16#8010#,
                   Convolution_2D           => 16#8011#,
                   Separable_2D             => 16#8012#,
                   Histogram                => 16#8024#,
                   Minmax                   => 16#802E#,
                   Polygon_Offset_Fill      => 16#8037#,
                   Rescale_Normal           => 16#803A#,
                   Texture_3D               => 16#806F#,
                   Multisample              => 16#809D#,
                   Sample_Alpha_To_Coverage => 16#809E#,
                   Sample_Alpha_To_One      => 16#809F#,
                   Sample_Coverage          => 16#80A0#,
                   Color_Table              => 16#80D0#,
                   Post_Convolution_Color_Table  => 16#80D1#,
                   Post_Color_Matrix_Color_Table => 16#80D2#,
                   Color_Sum                => 16#8458#,
                   Texture_Cube_Map         => 16#8513#,
                   Vertex_Program_Point_Size => 16#8642#,
                   Vertex_Program_Two_Side  => 16#8643#,
                   Point_Sprite             => 16#8861#,
                   Rasterizer_Discard       => 16#8C89#);
   for Toggle'Size use Low_Level.Enum'Size;

end GL.Toggles;

--------------------------------------------------------------------------------
-- Copyright (c) 2012, Felix Krause <contact@flyx.org>
--
-- Permission to use, copy, modify, and/or 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.
--------------------------------------------------------------------------------

private with GL.Low_Level;

package GL.Toggles is
   pragma Preelaborate;

   type Toggle_State is (Disabled, Enabled);

   type Toggle is (Point_Smooth, Line_Smooth, Line_Stipple, Polygon_Smooth, Polygon_Stipple,
                   Cull_Face, Lighting, Color_Material,
                   Fog, Depth_Test, Stencil_Test, Normalize, Alpha_Test, Dither,
                   Blend, Index_Logic_Op, Color_Logic_Op, Scissor_Test, Texture_Gen_S,
                   Texture_Gen_T, Texture_Gen_R, Texture_Gen_Q,
                   Auto_Normal,
                   Map1_Color_4, Map1_Index,
                   Map1_Normal, Map1_Texture_Coord_1, Map1_Texture_Coord_2,
                   Map1_Texture_Coord_3, Map1_Texture_Coord_4,
                   Map1_Vertex_3, Map1_Vertex_4, Map2_Color_4, Map2_Index,
                   Map2_Normal, Map2_Texture_Coord_1, Map2_Texture_Coord_2,
                   Map2_Texture_Coord_3, Map2_Texture_Coord_4, Map2_Vertex_3,
                   Map2_Vertex_4, Texture_1D, Texture_2D, Polygon_Offset_Point, Polygon_Offset_Line,
                   Clip_Plane_0, Clip_Plane_1,
                   Clip_Plane_2, Clip_Plane_3, Clip_Plane_4, Clip_Plane_5,
                   Light0, Light1, Light2, Light3, Light4, Light5, Light6, Light7,
                   Convolution_1D, Convolution_2D, Separable_2D, Histogram,
                   Minmax, Polygon_Offset_Fill, Rescale_Normal, Texture_3D, Multisample,
                   Sample_Alpha_To_Coverage, Sample_Alpha_To_One,
                   Sample_Coverage, Color_Table, Post_Convolution_Color_Table,
                   Post_Color_Matrix_Color_Table, Color_Sum, Texture_Cube_Map,
                   Vertex_Program_Point_Size, Vertex_Program_Two_Side,
                   Texture_Cube_Map_Seamless, Point_Sprite, Rasterizer_Discard);

   procedure Enable (Subject : Toggle);
   procedure Disable (Subject : Toggle);
   procedure Set (Subject : Toggle; Value : Toggle_State);
   function State (Subject : Toggle) return Toggle_State;
private
   for Toggle use (Point_Smooth             => 16#0B10#,
                   Line_Smooth              => 16#0B20#,
                   Line_Stipple             => 16#0B24#,
                   Polygon_Smooth           => 16#0B41#,
                   Polygon_Stipple          => 16#0B42#,
                   Cull_Face                => 16#0B44#,
                   Lighting                 => 16#0B50#,
                   Color_Material           => 16#0B57#,
                   Fog                      => 16#0B60#,
                   Depth_Test               => 16#0B71#,
                   Stencil_Test             => 16#0B90#,
                   Normalize                => 16#0BA1#,
                   Alpha_Test               => 16#0BC0#,
                   Dither                   => 16#0BD0#,
                   Blend                    => 16#0BE2#,
                   Index_Logic_Op           => 16#0BF1#,
                   Color_Logic_Op           => 16#0BF2#,
                   Scissor_Test             => 16#0C11#,
                   Texture_Gen_S            => 16#0C60#,
                   Texture_Gen_T            => 16#0C61#,
                   Texture_Gen_R            => 16#0C62#,
                   Texture_Gen_Q            => 16#0C63#,
                   Auto_Normal              => 16#0D80#,
                   Map1_Color_4             => 16#0D90#,
                   Map1_Index               => 16#0D91#,
                   Map1_Normal              => 16#0D92#,
                   Map1_Texture_Coord_1     => 16#0D93#,
                   Map1_Texture_Coord_2     => 16#0D94#,
                   Map1_Texture_Coord_3     => 16#0D95#,
                   Map1_Texture_Coord_4     => 16#0D96#,
                   Map1_Vertex_3            => 16#0D97#,
                   Map1_Vertex_4            => 16#0D98#,
                   Map2_Color_4             => 16#0DB0#,
                   Map2_Index               => 16#0DB1#,
                   Map2_Normal              => 16#0DB2#,
                   Map2_Texture_Coord_1     => 16#0DB3#,
                   Map2_Texture_Coord_2     => 16#0DB4#,
                   Map2_Texture_Coord_3     => 16#0DB5#,
                   Map2_Texture_Coord_4     => 16#0DB6#,
                   Map2_Vertex_3            => 16#0DB7#,
                   Map2_Vertex_4            => 16#0DB8#,
                   Texture_1D               => 16#0DE0#,
                   Texture_2D               => 16#0DE1#,
                   Polygon_Offset_Point     => 16#2A01#,
                   Polygon_Offset_Line      => 16#2A02#,
                   Clip_Plane_0             => 16#3000#,
                   Clip_Plane_1             => 16#3001#,
                   Clip_Plane_2             => 16#3002#,
                   Clip_Plane_3             => 16#3003#,
                   Clip_Plane_4             => 16#3004#,
                   Clip_Plane_5             => 16#3005#,
                   Light0                   => 16#4000#,
                   Light1                   => 16#4001#,
                   Light2                   => 16#4002#,
                   Light3                   => 16#4003#,
                   Light4                   => 16#4004#,
                   Light5                   => 16#4005#,
                   Light6                   => 16#4006#,
                   Light7                   => 16#4007#,
                   Convolution_1D           => 16#8010#,
                   Convolution_2D           => 16#8011#,
                   Separable_2D             => 16#8012#,
                   Histogram                => 16#8024#,
                   Minmax                   => 16#802E#,
                   Polygon_Offset_Fill      => 16#8037#,
                   Rescale_Normal           => 16#803A#,
                   Texture_3D               => 16#806F#,
                   Multisample              => 16#809D#,
                   Sample_Alpha_To_Coverage => 16#809E#,
                   Sample_Alpha_To_One      => 16#809F#,
                   Sample_Coverage          => 16#80A0#,
                   Color_Table              => 16#80D0#,
                   Post_Convolution_Color_Table  => 16#80D1#,
                   Post_Color_Matrix_Color_Table => 16#80D2#,
                   Color_Sum                => 16#8458#,
                   Texture_Cube_Map         => 16#8513#,
                   Vertex_Program_Point_Size => 16#8642#,
                   Vertex_Program_Two_Side  => 16#8643#,
                   Texture_Cube_Map_Seamless => 16#884F#,
                   Point_Sprite             => 16#8861#,
                   Rasterizer_Discard       => 16#8C89#);
   for Toggle'Size use Low_Level.Enum'Size;

end GL.Toggles;

Add seamless cube map filtering

gl: Add seamless cube map filtering

 * Extension ARB_seamless_cube_map (OpenGL 3.2)

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
package body Util.Properties.Bundles is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      overriding
      function Get_Value (From : in Manager;
                          Name : in String) return Util.Beans.Objects.Object;

      --  Set the value identified by the name.
      --  If the map contains the given name, the value changed.
      --  Otherwise name is added to the map and the value associated with it.
      overriding
      procedure Set_Value (From  : in out Manager;
                           Name  : in String;
                           Value : in Util.Beans.Objects.Object);

      --  Returns TRUE if the property exists.
      overriding
      function Exists (Self : in Manager;
                       Name : in String)
                       return Boolean;

      --  Remove the property given its name.
      overriding
      procedure Remove (Self : in out Manager; Name : in Value);

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      overriding
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value));

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                           return Util.Properties.Interface_P.Manager_Access;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl = null then
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      end if;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Integer := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Util.Concurrent.Counters.Increment (Bundle.Impl.Count);
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward) - 1;
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         subtype Cursor is Bundle_Map.Cursor;

         Base_Name   : aliased constant String := Name (Name'First .. Name'Last - 11);
         Pos         : constant Cursor := Factory.Bundles.Find (Base_Name'Unchecked_Access);
         Bundle_Name : Name_Access;
         Bundle      : Bundle_Manager_Access;
      begin
         Log.Debug ("Loading file {0}", File_Path);

         if Bundle_Map.Has_Element (Pos) then
            Bundle := Bundle_Map.Element (Pos);
         else
            Bundle := new Manager;
            Bundle_Name := new String '(Base_Name);
            Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
            Names.Insert (Bundle_Name);
         end if;
         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Found := True;
         Done := False;
      end Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Factory.Lock.Write;

      begin
         Util.Files.Iterate_Files_Path (Pattern => Pattern,
                                        Path    => Path,
                                        Process => Process_File'Access,
                                        Going   => Ada.Strings.Backward);

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      overriding
      function Get_Value (From : in Manager;
                          Name : in String) return Util.Beans.Objects.Object is
         Result : Util.Beans.Objects.Object := From.Props.Get_Value (Name);
      begin
         if Util.Beans.Objects.Is_Null (Result) then
            declare
               Iter : Cursor := From.List.First;
            begin
               while Has_Element (Iter) loop
                  Result := Element (Iter).all.Get_Value (Name);
                  exit when not Util.Beans.Objects.Is_Null (Result);
                  Iter := Next (Iter);
               end loop;
            end;
         end if;
         return Result;
      end Get_Value;

      --  Set the value identified by the name.
      --  If the map contains the given name, the value changed.
      --  Otherwise name is added to the map and the value associated with it.
      overriding
      procedure Set_Value (From  : in out Manager;
                           Name  : in String;
                           Value : in Util.Beans.Objects.Object) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Set_Value;

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in String)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager; Name : in Value) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name, Item : Value)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      function Get_Names (Self   : in Manager;
                          Prefix : in String) return Name_Array is
         Result : Name_Array (1 .. 2);
         Iter   : constant Cursor := Self.List.First;
      begin
         while Has_Element (Iter) loop
            declare
               M : constant Util.Properties.Manager_Access := Element (Iter);
               N : constant Name_Array := M.Get_Names (Prefix);
            begin
               return N;
            end;
         end loop;
         return Result;
      end Get_Names;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Ada.Strings.Unbounded.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

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

with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Ada.Directories;
with Ada.Containers.Vectors;
with Ada.Strings.Fixed;
with Util.Log.Loggers;
with Util.Files;
package body Util.Properties.Bundles is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Properties.Bundles");

   procedure Free is
     new Ada.Unchecked_Deallocation (Manager'Class,
                                     Bundle_Manager_Access);

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package Interface_P is

      type Manager is new Util.Properties.Interface_P.Manager with private;
      type Manager_Object_Access is access all Manager;

      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      overriding
      function Get_Value (From : in Manager;
                          Name : in String) return Util.Beans.Objects.Object;

      --  Set the value identified by the name.
      --  If the map contains the given name, the value changed.
      --  Otherwise name is added to the map and the value associated with it.
      overriding
      procedure Set_Value (From  : in out Manager;
                           Name  : in String;
                           Value : in Util.Beans.Objects.Object);

      --  Returns TRUE if the property exists.
      overriding
      function Exists (Self : in Manager;
                       Name : in String)
                       return Boolean;

      --  Remove the property given its name.
      overriding
      procedure Remove (Self : in out Manager;
                        Name : in String);

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      overriding
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name : in String;
                                                     Item : in Util.Beans.Objects.Object));

      procedure Load_Properties (Self : in out Manager;
                                 File : in String);

      --  Deep copy of properties stored in 'From' to 'To'.
      function Create_Copy (Self : in Manager)
                           return Util.Properties.Interface_P.Manager_Access;

      procedure Add_Bundle (Self : in out Manager;
                            Props : in Util.Properties.Manager_Access);
   private
      use type Util.Properties.Manager_Access;

      package PropertyList is new Ada.Containers.Vectors
        (Element_Type => Util.Properties.Manager_Access,
         Index_Type => Natural,
           "=" => "=");

      type Manager is new Util.Properties.Interface_P.Manager with record
         List  : PropertyList.Vector;
         Props : aliased Util.Properties.Manager;
      end record;

      procedure Free is
        new Ada.Unchecked_Deallocation (Manager,
                                        Manager_Object_Access);
   end Interface_P;

   procedure Add_Bundle (Self  : in out Manager;
                         Props : in Manager_Access) is
      use type Util.Properties.Interface_P.Manager_Access;
   begin
      Interface_P.Manager'Class (Self.Impl.all).Add_Bundle (Props);
   end Add_Bundle;

   procedure Initialize (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Initialize;

   procedure Adjust (Object : in out Manager) is
      use Util.Properties.Interface_P;
   begin
      if Object.Impl = null then
         Object.Impl := new Util.Properties.Bundles.Interface_P.Manager;
      end if;
      Util.Concurrent.Counters.Increment (Object.Impl.Count);
   end Adjust;

   --  ------------------------------
   --  Initialize the bundle factory and specify where the property files are stored.
   --  ------------------------------
   procedure Initialize (Factory : in out Loader;
                         Path    : in String) is
   begin
      Log.Info ("Initialize bundle factory to load from {0}", Path);

      Factory.Path := To_Unbounded_String (Path);
   end Initialize;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class) is
      Found : Boolean := False;
   begin
      Log.Info ("Load bundle {0} for language {1}", Name, Locale);

      Find_Bundle (Factory, Name, Locale, Bundle, Found);
      if not Found then
         Load_Bundle (Factory, Name, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
         Find_Bundle (Factory, Name, Locale, Bundle, Found);
         if not Found then
            Log.Error ("Bundle {0} not found", Name);
            raise NO_BUNDLE with "No bundle '" & Name & "'";
         end if;
      end if;
   end Load_Bundle;

   --  ------------------------------
   --  Find the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Find_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Locale  : in String;
                          Bundle  : out Manager'Class;
                          Found   : out Boolean) is
      use Ada.Strings;
      use type Util.Properties.Manager_Access;

      Loc_Name : constant String := '_' & Locale;
      Last_Pos : Integer := Loc_Name'Last;
   begin
      Log.Info ("Looking for bundle {0} and language {1}", Name, Locale);

      Found := False;
      Factory.Lock.Read;
      declare
         Pos : Bundle_Map.Cursor;
      begin
         while Last_Pos + 1 >= Loc_Name'First loop
            declare
               Bundle_Name : aliased constant String
                 := Name & Loc_Name (Loc_Name'First .. Last_Pos);
            begin
               Log.Debug ("Searching for {0}", Bundle_Name);
               Pos := Factory.Bundles.Find (Bundle_Name'Unrestricted_Access);
               if Bundle_Map.Has_Element (Pos) then
                  Bundle.Finalize;
                  Bundle.Impl := Bundle_Map.Element (Pos).Impl;
                  Util.Concurrent.Counters.Increment (Bundle.Impl.Count);
                  Found := True;
                  exit;
               end if;
            end;
            if Last_Pos > Loc_Name'First then
               Last_Pos := Fixed.Index (Loc_Name, "_", Last_Pos - 1, Backward) - 1;
            else
               Last_Pos := Last_Pos - 1;
            end if;
         end loop;
      exception
         when others =>
            Factory.Lock.Release_Read;
            raise;
      end;
      Factory.Lock.Release_Read;
   end Find_Bundle;

   --  ------------------------------
   --  Load the bundle with the given name and for the given locale name.
   --  ------------------------------
   procedure Load_Bundle (Factory : in out Loader;
                          Name    : in String;
                          Found   : out Boolean) is
      use Ada.Directories;
      use Ada.Strings;
      use Util.Strings;
      use Ada.Containers;
      use Util.Strings.String_Set;
      use Bundle_Map;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean);

      Path    : constant String := To_String (Factory.Path);
      Pattern : constant String := Name & "*.properties";
      Names   : Util.Strings.String_Set.Set;

      procedure Process_File (Name      : in String;
                              File_Path : in String;
                              Done      : out Boolean) is
         subtype Cursor is Bundle_Map.Cursor;

         Base_Name   : aliased constant String := Name (Name'First .. Name'Last - 11);
         Pos         : constant Cursor := Factory.Bundles.Find (Base_Name'Unchecked_Access);
         Bundle_Name : Name_Access;
         Bundle      : Bundle_Manager_Access;
      begin
         Log.Debug ("Loading file {0}", File_Path);

         if Bundle_Map.Has_Element (Pos) then
            Bundle := Bundle_Map.Element (Pos);
         else
            Bundle := new Manager;
            Bundle_Name := new String '(Base_Name);
            Factory.Bundles.Include (Key => Bundle_Name, New_Item => Bundle);
            Names.Insert (Bundle_Name);
         end if;
         Interface_P.Manager'Class (Bundle.Impl.all).Load_Properties (File_Path);
         Found := True;
         Done := False;
      end Process_File;

   begin
      Log.Info ("Reading bundle {1} in directory {0}", Path, Name);

      Found := False;
      Factory.Lock.Write;

      begin
         Util.Files.Iterate_Files_Path (Pattern => Pattern,
                                        Path    => Path,
                                        Process => Process_File'Access,
                                        Going   => Ada.Strings.Backward);

         --  Link the property files to implement the localization default rules.
         while Names.Length > 0 loop
            declare
               Name_Pos    : String_Set.Cursor := Names.First;
               Bundle_Name : constant Name_Access := String_Set.Element (Name_Pos);
               Idx         : Natural := Fixed.Index (Bundle_Name.all, "_", Backward);
               Bundle_Pos  : constant Bundle_Map.Cursor := Factory.Bundles.Find (Bundle_Name);
               Bundle      : constant Bundle_Manager_Access := Element (Bundle_Pos);
            begin
               Names.Delete (Name_Pos);

               --  Associate the property bundle to the first existing parent
               --  Ex:  message_fr_CA -> message_fr
               --       message_fr_CA -> message
               while Idx > 0 loop
                  declare
                     Name : aliased constant String
                       := Bundle_Name (Bundle_Name'First .. Idx - 1);
                     Pos : constant Bundle_Map.Cursor
                       := Factory.Bundles.Find (Name'Unchecked_Access);
                  begin
                     if Bundle_Map.Has_Element (Pos) then
                        Bundle.Add_Bundle (Bundle_Map.Element (Pos).all'Access);
                        Idx := 0;
                     else
                        Idx := Fixed.Index (Bundle_Name.all, "_", Idx - 1, Backward);
                     end if;
                  end;
               end loop;
            end;
         end loop;

      exception
         when others =>
            Factory.Lock.Release_Write;
            raise;
      end;
      Factory.Lock.Release_Write;

   exception
      when Name_Error =>
         Log.Error ("Cannot read directory: {0}", Path);

   end Load_Bundle;

   --  Implementation of the Bundle
   --  (this allows to decouples the implementation from the API)
   package body Interface_P is
      use PropertyList;

      --  Get the value identified by the name.
      --  If the name cannot be found, the method should return the Null object.
      overriding
      function Get_Value (From : in Manager;
                          Name : in String) return Util.Beans.Objects.Object is
         Result : Util.Beans.Objects.Object := From.Props.Get_Value (Name);
      begin
         if Util.Beans.Objects.Is_Null (Result) then
            declare
               Iter : Cursor := From.List.First;
            begin
               while Has_Element (Iter) loop
                  Result := Element (Iter).all.Get_Value (Name);
                  exit when not Util.Beans.Objects.Is_Null (Result);
                  Iter := Next (Iter);
               end loop;
            end;
         end if;
         return Result;
      end Get_Value;

      --  Set the value identified by the name.
      --  If the map contains the given name, the value changed.
      --  Otherwise name is added to the map and the value associated with it.
      overriding
      procedure Set_Value (From  : in out Manager;
                           Name  : in String;
                           Value : in Util.Beans.Objects.Object) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Set_Value;

      --  ------------------------------
      --  Returns TRUE if the property exists.
      --  ------------------------------
      function Exists (Self : in Manager; Name : in String)
                      return Boolean is
         Iter : Cursor := Self.List.First;
      begin
         if Self.Props.Exists (Name) then
            return True;
         end if;
         while Has_Element (Iter) loop
            if Element (Iter).Exists (Name) then
               return True;
            end if;
            Iter := Next (Iter);
         end loop;
         return False;
      end Exists;

      procedure Load_Properties (Self : in out Manager;
                                 File : in String) is
      begin
         Self.Props.Load_Properties (File);
      end Load_Properties;

      --  ------------------------------
      --  Remove the property given its name.
      --  ------------------------------
      procedure Remove (Self : in out Manager;
                        Name : in String) is
      begin
         raise NOT_WRITEABLE with "Bundle is readonly";
      end Remove;

      --  Iterate over the properties and execute the given procedure passing the
      --  property name and its value.
      procedure Iterate (Self    : in Manager;
                         Process : access procedure (Name : in String;
                                                     Item : in Util.Beans.Objects.Object)) is
      begin
         raise Program_Error with "Iterate is not implemented on Bundle";
      end Iterate;

      --  ------------------------------
      --  Deep copy of properties stored in 'From' to 'To'.
      --  ------------------------------
      function Create_Copy (Self : in Manager)
                            return Util.Properties.Interface_P.Manager_Access is
         pragma Unreferenced (Self);
      begin
         return null;
      end Create_Copy;

      procedure Add_Bundle (Self  : in out Manager;
                            Props : in Util.Properties.Manager_Access) is
      begin
         Self.List.Append (Props);
      end Add_Bundle;

   end Interface_P;

   --  ------------------------------
   --  Clear the bundle cache
   --  ------------------------------
   procedure Clear_Cache (Factory : in out Loader) is
      use Util.Strings;
      use Bundle_Map;

      function To_String_Access is
        new Ada.Unchecked_Conversion (Source => Util.Strings.Name_Access,
                                      Target => Ada.Strings.Unbounded.String_Access);

   begin
      Log.Info ("Clearing bundle cache");

      Factory.Lock.Write;
      loop
         declare
            Pos  : Bundle_Map.Cursor := Factory.Bundles.First;
            Name : Ada.Strings.Unbounded.String_Access;
            Node : Bundle_Manager_Access;
         begin
            exit when not Has_Element (Pos);
            Node := Element (Pos);
            Name := To_String_Access (Key (Pos));
            Factory.Bundles.Delete (Pos);
            Free (Node);
            Free (Name);
         end;
      end loop;
      Factory.Lock.Release_Write;
   end Clear_Cache;

   --  ------------------------------
   --  Finalize the bundle loader and clear the cache
   --  ------------------------------
   procedure Finalize (Factory : in out Loader) is
   begin
      Clear_Cache (Factory);
   end Finalize;

end Util.Properties.Bundles;

Refactor the Properties implementation (step 3): - Update the bundles implementation


-----------------------------------------------------------------------
--  awa-events-queues-persistents -- AWA Event Queues
--  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 Ada.Calendar;
with Ada.Strings.Unbounded;

with Util.Log.Loggers;

with Util.Serialize.Tools;

with AWA.Services.Contexts;
with AWA.Users.Models;
with AWA.Applications;
with AWA.Events.Services;

with ADO;
with ADO.Queries;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Events.Queues.Persistents is

   package AC renames AWA.Services.Contexts;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Queues.Persistents");

   --  ------------------------------
   --  Get the queue name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Persistent_Queue) return String is
   begin
      return From.Name;
   end Get_Name;

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   overriding
   function Get_Queue (From : in Persistent_Queue) return AWA.Events.Models.Queue_Ref is
   begin
      return From.Queue;
   end Get_Queue;

   --  ------------------------------
   --  Queue the event.  The event is saved in the database with a relation to
   --  the user, the user session, the event queue and the event type.
   --  ------------------------------
   overriding
   procedure Enqueue (Into  : in out Persistent_Queue;
                      Event : in AWA.Events.Module_Event'Class) is
      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager);

      Ctx   : constant AC.Service_Context_Access := AC.Current;
      App   : constant AWA.Applications.Application_Access := Ctx.Get_Application;
      DB    : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Msg   : AWA.Events.Models.Message_Ref;

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager) is
      begin
         Manager.Set_Message_Type (Msg, Event.Get_Event_Kind);
      end Set_Event;

   begin
      App.Do_Event_Manager (Set_Event'Access);
      Ctx.Start;
      Msg.Set_Queue (Into.Queue);
      Msg.Set_User (Ctx.Get_User);
      Msg.Set_Session (Ctx.Get_User_Session);
      Msg.Set_Create_Date (Event.Get_Time);
      Msg.Set_Status (AWA.Events.Models.QUEUED);

      --  Collect the event parameters in a string and format the result in JSON.
      Msg.Set_Parameters (Util.Serialize.Tools.To_JSON (Event.Props));
      Msg.Save (DB);
      Ctx.Commit;

      Log.Info ("Event {0} created", ADO.Identifier'Image (Msg.Get_Id));
   end Enqueue;

   overriding
   procedure Dequeue (From : in out Persistent_Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is

      --  Prepare the message by indicating in the database it is going to be processed
      --  by the given server and task.
      procedure Prepare_Message (Msg : in out Models.Message_Ref);

      --  Dispatch the event.
      procedure Dispatch_Message (Msg : in out Models.Message_Ref);

      --  Finish processing the message by marking it as being processed.
      procedure Finish_Message (Msg : in out Models.Message_Ref);

      Ctx      : constant AC.Service_Context_Access := AC.Current;
      DB       : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Messages : Models.Message_Vector;
      Query    : ADO.Queries.Context;
      Task_Id  : Integer := 0;

      --  ------------------------------
      --  Prepare the message by indicating in the database it is going to be processed
      --  by the given server and task.
      --  ------------------------------
      procedure Prepare_Message (Msg : in out Models.Message_Ref) is
      begin
         Msg.Set_Status (Models.PROCESSING);
         Msg.Set_Server_Id (From.Server_Id);
         Msg.Set_Task_Id (Task_Id);
         Msg.Set_Processing_Date (ADO.Nullable_Time '(Is_Null => False,
                                                      Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
      end Prepare_Message;

      --  Dispatch the event.
      procedure Dispatch_Message (Msg : in out Models.Message_Ref) is
         User    : constant AWA.Users.Models.User_Ref'Class := Msg.Get_User;
         Session : constant AWA.Users.Models.Session_Ref'Class := Msg.Get_Session;
         Event   : Module_Event;
      begin
         Event.Set_Event_Kind (AWA.Events.Find_Event_Index (Msg.Get_Message_Type.Get_Name));
         Util.Serialize.Tools.From_JSON (Msg.Get_Parameters, Event.Props);
         Process (Event);

      exception
         when E : others =>
            Log.Error ("Exception when processing event", E, True);

      end Dispatch_Message;

      --  ------------------------------
      --  Finish processing the message by marking it as being processed.
      --  ------------------------------
      procedure Finish_Message (Msg : in out Models.Message_Ref) is
      begin
         Msg.Set_Status (Models.PROCESSED);
         Msg.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                  Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
      end Finish_Message;

      Count : Natural;
   begin
      Ctx.Start;
      Query.Set_Query (Models.Query_Queue_Pending_Message);
      Query.Bind_Param ("queue", From.Queue.Get_Id);
      Query.Bind_Param ("max", From.Max_Batch);
      Models.List (Messages, DB, Query);
      Count := Natural (Messages.Length);

      --  Prepare the event messages by marking them in the database.
      --  This makes sure that no other server or task (if any), will process them.
      if Count > 0 then
         for I in 0 .. Count - 1 loop
            Messages.Update_Element (Index   => I,
                                     Process => Prepare_Message'Access);
         end loop;
      end if;
      Ctx.Commit;

      if Count = 0 then
         return;
      end if;

      Log.Info ("Dispatching {0} events", Natural'Image (Count));

      --  Dispatch each event.
      for I in 0 .. Count - 1 loop
         Messages.Update_Element (Index   => I,
                                  Process => Dispatch_Message'Access);
      end loop;

      --  After having dispatched the events, mark them as dispatched in the queue.
      Ctx.Start;
      for I in 0 .. Count - 1 loop
         Messages.Update_Element (Index   => I,
                                  Process => Finish_Message'Access);
      end loop;
      Ctx.Commit;
   end Dequeue;

   --  ------------------------------
   --  Create the queue associated with the given name and configure it by using
   --  the configuration properties.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class) return Queue_Access is
      package AC renames AWA.Services.Contexts;

      Ctx     : constant AC.Service_Context_Access := AC.Current;
      Session : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Queue   : AWA.Events.Models.Queue_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      Session.Begin_Transaction;
      --  Find the queue instance which matches the name.
      Query.Set_Filter ("o.name = ?");
      Query.Add_Param (Name);
      Queue.Find (Session => Session,
                  Query   => Query,
                  Found   => Found);

      --  But create the queue instance if it does not exist.
      if not Found then
         Log.Info ("Creating database queue {0}", Name);
         Queue.Set_Name (Name);
         Queue.Save (Session);
      else
         Log.Info ("Using database queue {0}", Name);
      end if;
      Session.Commit;
      declare
         Result : constant Persistent_Queue_Access
           := new Persistent_Queue '(Name_Length  => Name'Length,
                                     Name         => Name,
                                     Queue        => Queue,
                                     others       => <>);
      begin
         return Result.all'Access;
      end;
   end Create_Queue;

end AWA.Events.Queues.Persistents;

-----------------------------------------------------------------------
--  awa-events-queues-persistents -- AWA Event Queues
--  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 Ada.Calendar;
with Ada.Strings.Unbounded;

with Util.Log.Loggers;

with Util.Serialize.Tools;

with AWA.Services.Contexts;
with AWA.Users.Models;
with AWA.Applications;
with AWA.Events.Services;

with ADO;
with ADO.Queries;
with ADO.Sessions;
with ADO.SQL;
package body AWA.Events.Queues.Persistents is

   package AC renames AWA.Services.Contexts;

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("AWA.Events.Queues.Persistents");

   --  ------------------------------
   --  Get the queue name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Persistent_Queue) return String is
   begin
      return From.Name;
   end Get_Name;

   --  ------------------------------
   --  Get the model queue reference object.
   --  Returns a null object if the queue is not persistent.
   --  ------------------------------
   overriding
   function Get_Queue (From : in Persistent_Queue) return AWA.Events.Models.Queue_Ref is
   begin
      return From.Queue;
   end Get_Queue;

   --  ------------------------------
   --  Queue the event.  The event is saved in the database with a relation to
   --  the user, the user session, the event queue and the event type.
   --  ------------------------------
   overriding
   procedure Enqueue (Into  : in out Persistent_Queue;
                      Event : in AWA.Events.Module_Event'Class) is
      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager);

      Ctx   : constant AC.Service_Context_Access := AC.Current;
      App   : constant AWA.Applications.Application_Access := Ctx.Get_Application;
      DB    : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Msg   : AWA.Events.Models.Message_Ref;

      procedure Set_Event (Manager : in out AWA.Events.Services.Event_Manager) is
      begin
         Manager.Set_Message_Type (Msg, Event.Get_Event_Kind);
      end Set_Event;

   begin
      App.Do_Event_Manager (Set_Event'Access);
      Ctx.Start;
      Msg.Set_Queue (Into.Queue);
      Msg.Set_User (Ctx.Get_User);
      Msg.Set_Session (Ctx.Get_User_Session);
      Msg.Set_Create_Date (Event.Get_Time);
      Msg.Set_Status (AWA.Events.Models.QUEUED);
      Msg.Set_Entity_Id (Event.Get_Entity_Identifier);
      Msg.Set_Entity_Type (Event.Entity_Type);

      --  Collect the event parameters in a string and format the result in JSON.
      Msg.Set_Parameters (Util.Serialize.Tools.To_JSON (Event.Props));
      Msg.Save (DB);
      Ctx.Commit;

      Log.Info ("Event {0} created", ADO.Identifier'Image (Msg.Get_Id));
   end Enqueue;

   overriding
   procedure Dequeue (From : in out Persistent_Queue;
                      Process : access procedure (Event : in Module_Event'Class)) is

      --  Prepare the message by indicating in the database it is going to be processed
      --  by the given server and task.
      procedure Prepare_Message (Msg : in out Models.Message_Ref);

      --  Dispatch the event.
      procedure Dispatch_Message (Msg : in out Models.Message_Ref);

      --  Finish processing the message by marking it as being processed.
      procedure Finish_Message (Msg : in out Models.Message_Ref);

      Ctx      : constant AC.Service_Context_Access := AC.Current;
      DB       : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Messages : Models.Message_Vector;
      Query    : ADO.Queries.Context;
      Task_Id  : Integer := 0;

      --  ------------------------------
      --  Prepare the message by indicating in the database it is going to be processed
      --  by the given server and task.
      --  ------------------------------
      procedure Prepare_Message (Msg : in out Models.Message_Ref) is
      begin
         Msg.Set_Status (Models.PROCESSING);
         Msg.Set_Server_Id (From.Server_Id);
         Msg.Set_Task_Id (Task_Id);
         Msg.Set_Processing_Date (ADO.Nullable_Time '(Is_Null => False,
                                                      Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
      end Prepare_Message;

      --  Dispatch the event.
      procedure Dispatch_Message (Msg : in out Models.Message_Ref) is
         User    : constant AWA.Users.Models.User_Ref'Class := Msg.Get_User;
         Session : constant AWA.Users.Models.Session_Ref'Class := Msg.Get_Session;
         Event   : Module_Event;
      begin
         Event.Set_Event_Kind (AWA.Events.Find_Event_Index (Msg.Get_Message_Type.Get_Name));
         Util.Serialize.Tools.From_JSON (Msg.Get_Parameters, Event.Props);
         Event.Set_Entity_Identifier (Msg.Get_Entity_Id);
         Event.Entity_Type := Msg.Get_Entity_Type;
         Process (Event);

      exception
         when E : others =>
            Log.Error ("Exception when processing event", E, True);

      end Dispatch_Message;

      --  ------------------------------
      --  Finish processing the message by marking it as being processed.
      --  ------------------------------
      procedure Finish_Message (Msg : in out Models.Message_Ref) is
      begin
         Msg.Set_Status (Models.PROCESSED);
         Msg.Set_Finish_Date (ADO.Nullable_Time '(Is_Null => False,
                                                  Value   => Ada.Calendar.Clock));
         Msg.Save (DB);
      end Finish_Message;

      Count : Natural;
   begin
      Ctx.Start;
      Query.Set_Query (Models.Query_Queue_Pending_Message);
      Query.Bind_Param ("queue", From.Queue.Get_Id);
      Query.Bind_Param ("max", From.Max_Batch);
      Models.List (Messages, DB, Query);
      Count := Natural (Messages.Length);

      --  Prepare the event messages by marking them in the database.
      --  This makes sure that no other server or task (if any), will process them.
      if Count > 0 then
         for I in 0 .. Count - 1 loop
            Messages.Update_Element (Index   => I,
                                     Process => Prepare_Message'Access);
         end loop;
      end if;
      Ctx.Commit;

      if Count = 0 then
         return;
      end if;

      Log.Info ("Dispatching {0} events", Natural'Image (Count));

      --  Dispatch each event.
      for I in 0 .. Count - 1 loop
         Messages.Update_Element (Index   => I,
                                  Process => Dispatch_Message'Access);
      end loop;

      --  After having dispatched the events, mark them as dispatched in the queue.
      Ctx.Start;
      for I in 0 .. Count - 1 loop
         Messages.Update_Element (Index   => I,
                                  Process => Finish_Message'Access);
      end loop;
      Ctx.Commit;
   end Dequeue;

   --  ------------------------------
   --  Create the queue associated with the given name and configure it by using
   --  the configuration properties.
   --  ------------------------------
   function Create_Queue (Name    : in String;
                          Props   : in EL.Beans.Param_Vectors.Vector;
                          Context : in EL.Contexts.ELContext'Class) return Queue_Access is
      package AC renames AWA.Services.Contexts;

      Ctx     : constant AC.Service_Context_Access := AC.Current;
      Session : ADO.Sessions.Master_Session := AC.Get_Master_Session (Ctx);
      Queue   : AWA.Events.Models.Queue_Ref;
      Query   : ADO.SQL.Query;
      Found   : Boolean;
   begin
      Session.Begin_Transaction;
      --  Find the queue instance which matches the name.
      Query.Set_Filter ("o.name = ?");
      Query.Add_Param (Name);
      Queue.Find (Session => Session,
                  Query   => Query,
                  Found   => Found);

      --  But create the queue instance if it does not exist.
      if not Found then
         Log.Info ("Creating database queue {0}", Name);
         Queue.Set_Name (Name);
         Queue.Save (Session);
      else
         Log.Info ("Using database queue {0}", Name);
      end if;
      Session.Commit;
      declare
         Result : constant Persistent_Queue_Access
           := new Persistent_Queue '(Name_Length  => Name'Length,
                                     Name         => Name,
                                     Queue        => Queue,
                                     others       => <>);
      begin
         return Result.all'Access;
      end;
   end Create_Queue;

end AWA.Events.Queues.Persistents;

Save and restore the entity identifier associated with an event


------------------------------------------------------------------------------
-- Copyright (c) 2014, 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.S_Expressions.Atom_Buffers implements an unbounded Atom designed --
-- to be used as an input buffer, accumulating data and extracting it as a  --
-- single Atom object.                                                      --
-- It also provides an individual Octet accessor, used in parser internal   --
-- recursive buffer.                                                        --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Refs;

package Natools.S_Expressions.Atom_Buffers is
   pragma Preelaborate (Atom_Buffers);

   type Atom_Buffer is tagged private;
   pragma Preelaborable_Initialization (Atom_Buffer);

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count);
      --  Preallocate enough memory to append Length octets without
      --  any further allocation.

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom);
   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet);
      --  Append Data after the end of Buffer

   procedure Append_Reverse (Buffer : in out Atom_Buffer; Data : in Atom);
      --  Append bytes from Atom from last to first

   procedure Invert (Buffer : in out Atom_Buffer);
      --  Invert the order of bytes (first becomes last, etc)

   function Length (Buffer : Atom_Buffer) return Count;
   function Capacity (Buffer : Atom_Buffer) return Count;
   function Data (Buffer : Atom_Buffer) return Atom;
   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom));
   procedure Read
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count);
   function Element (Buffer : Atom_Buffer; Position : Count) return Octet;
      --  Accessors to the whole buffer as an Atom

   procedure Pop (Buffer : in out Atom_Buffer; Data : out Octet);
      --  Remove last octet from Buffer and store it in Data

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor;
      --  Accessor to the whole allocated memory

   procedure Hard_Reset (Buffer : in out Atom_Buffer);
      --  Clear buffer and release internal memory

   procedure Soft_Reset (Buffer : in out Atom_Buffer);
      --  Clear buffer keeping internal memory

private

   type Atom_Buffer is tagged record
      Ref : Atom_Refs.Reference;
      Available, Used : Count := 0;
   end record;

end Natools.S_Expressions.Atom_Buffers;

------------------------------------------------------------------------------
-- Copyright (c) 2014, 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.S_Expressions.Atom_Buffers implements an unbounded Atom designed --
-- to be used as an input buffer, accumulating data and extracting it as a  --
-- single Atom object.                                                      --
-- It also provides an individual Octet accessor, used in parser internal   --
-- recursive buffer.                                                        --
------------------------------------------------------------------------------

with Natools.S_Expressions.Atom_Refs;

package Natools.S_Expressions.Atom_Buffers is
   pragma Preelaborate (Atom_Buffers);

   type Atom_Buffer is tagged limited private;
   pragma Preelaborable_Initialization (Atom_Buffer);

   procedure Preallocate (Buffer : in out Atom_Buffer; Length : in Count);
      --  Preallocate enough memory to append Length octets without
      --  any further allocation.

   procedure Append (Buffer : in out Atom_Buffer; Data : in Atom);
   procedure Append (Buffer : in out Atom_Buffer; Data : in Octet);
      --  Append Data after the end of Buffer

   procedure Append_Reverse (Buffer : in out Atom_Buffer; Data : in Atom);
      --  Append bytes from Atom from last to first

   procedure Invert (Buffer : in out Atom_Buffer);
      --  Invert the order of bytes (first becomes last, etc)

   function Length (Buffer : Atom_Buffer) return Count;
   function Capacity (Buffer : Atom_Buffer) return Count;
   function Data (Buffer : Atom_Buffer) return Atom;
   procedure Query
     (Buffer : in Atom_Buffer;
      Process : not null access procedure (Data : in Atom));
   procedure Read
     (Buffer : in Atom_Buffer;
      Data : out Atom;
      Length : out Count);
   function Element (Buffer : Atom_Buffer; Position : Count) return Octet;
      --  Accessors to the whole buffer as an Atom

   procedure Pop (Buffer : in out Atom_Buffer; Data : out Octet);
      --  Remove last octet from Buffer and store it in Data

   function Raw_Query (Buffer : Atom_Buffer) return Atom_Refs.Accessor;
      --  Accessor to the whole allocated memory

   procedure Hard_Reset (Buffer : in out Atom_Buffer);
      --  Clear buffer and release internal memory

   procedure Soft_Reset (Buffer : in out Atom_Buffer);
      --  Clear buffer keeping internal memory

private

   type Atom_Buffer is tagged limited record
      Ref : Atom_Refs.Reference;
      Available, Used : Count := 0;
   end record;

end Natools.S_Expressions.Atom_Buffers;

s_expressions-atom_buffers: make Atom_Buffer type limited, since copying such objects would cause complex and useless consequences