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

with ADO;
with AWA.Users.Models;
with ASF.Principals;
with Security.Permissions;
package AWA.Users.Principals is

   type Principal is new ASF.Principals.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Security.Permissions.Role_Type) return Boolean;

   --  Get the principal identifier (name)
   function Get_Id (From : in Principal) return String;

   --  Get the user associated with the principal.
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref;

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   function Get_User_Identifier (From : in Principal) return ADO.Identifier;

   --  Get the connection session used by the user.
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref;

   --  Get the connection session identifier used by the user.
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier;

   --  Create a principal for the given user.
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access;

   --  Utility functions based on the security principal access type.

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   function Get_User_Identifier (From : in Security.Permissions.Principal_Access)
                                 return ADO.Identifier;

private

   type Principal is new ASF.Principals.Principal with record
      User        : AWA.Users.Models.User_Ref;
      Session     : AWA.Users.Models.Session_Ref;
      Roles       : Security.Permissions.Role_Map;
   end record;

end AWA.Users.Principals;

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

with ADO;
with AWA.Users.Models;
with ASF.Principals;
with Security.Permissions;
package AWA.Users.Principals is

   type Principal is new ASF.Principals.Principal with private;
   type Principal_Access is access all Principal'Class;

   --  Get the principal name.
   function Get_Name (From : in Principal) return String;

   --  Returns true if the given role is stored in the user principal.
   function Has_Role (User : in Principal;
                      Role : in Security.Permissions.Role_Type) return Boolean;

   --  Get the principal identifier (name)
   function Get_Id (From : in Principal) return String;

   --  Get the user associated with the principal.
   function Get_User (From : in Principal) return AWA.Users.Models.User_Ref;

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none.
   function Get_User_Identifier (From : in Principal) return ADO.Identifier;

   --  Get the connection session used by the user.
   function Get_Session (From : in Principal) return AWA.Users.Models.Session_Ref;

   --  Get the connection session identifier used by the user.
   function Get_Session_Identifier (From : in Principal) return ADO.Identifier;

   --  Create a principal for the given user.
   function Create (User    : in AWA.Users.Models.User_Ref;
                    Session : in AWA.Users.Models.Session_Ref) return Principal_Access;

   --  Utility functions based on the security principal access type.

   --  Get the current user identifier invoking the service operation.
   --  Returns NO_IDENTIFIER if there is none or if the principal is not an AWA principal.
   function Get_User_Identifier (From : in ASF.Principals.Principal_Access)
                                 return ADO.Identifier;

private

   type Principal is new ASF.Principals.Principal with record
      User        : AWA.Users.Models.User_Ref;
      Session     : AWA.Users.Models.Session_Ref;
      Roles       : Security.Permissions.Role_Map;
   end record;

end AWA.Users.Principals;

Use ASF Principal definitions

Use ASF Principal definitions


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

with System;

with Util.Properties;

with MAT.Types;
with MAT.Events;
package MAT.Readers is

   type Buffer_Type is private;
   type Buffer_Ptr is access Buffer_Type;

   type Message is record
      Kind   : MAT.Events.Event_Type;
      Size   : Natural;
      Buffer : Buffer_Ptr;
   end record;

   -----------------
   --  Abstract servant definition
   -----------------
   --  The Servant is a small proxy that binds the specific message
   --  handlers to the client specific dispatcher.
   type Reader_Base is abstract tagged limited private;
   type Reader_Access is access all Reader_Base'Class;

   procedure Dispatch (For_Servant : in out Reader_Base;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Msg         : in out Message) is abstract;
   --  Dispatch the message

   procedure Bind (For_Servant : in out Reader_Base) is abstract;
   --  Bind the servant with the object adapter to register the
   --  events it recognizes.  This is called once we have all the
   --  information about the structures of events that we can
   --  receive.

   -----------------
   --  Ipc Client Manager
   -----------------
   --  The Manager is a kind of object adapter. It registers a collection
   --  of servants and dispatches incomming messages to those servants.
   type Manager_Base is tagged limited private;
   type Manager is access all Manager_Base'Class;

   procedure Register_Servant (Adapter : in Manager;
                               Proxy   : in Reader_Access);
   --  Register the proxy servant in the object adapter.

--     function Get_Manager (Refs : in ClientInfo_Ref_Map) return Manager;
   --  Return the object adapter manager which holds all the servant
   --  for the client.

   procedure Register_Message_Analyzer (Proxy  : in Reader_Access;
                                        Name   : in String;
                                        Id     : in MAT.Events.Internal_Reference;
                                        Model  : in MAT.Events.Attribute_Table;
                                        Table  : out MAT.Events.Attribute_Table_Ptr);
   --  Setup the servant to receive and process messages identified
   --  by Name.

   procedure Dispatch_Message (Client : in out Manager_Base;
                               Msg    : in out Message);

private

   type Buffer_Type is record
      Current : System.Address;
      Start   : System.Address;
      Last    : System.Address;
      Size    : Natural;
      Total   : Natural;
   end record;

   type Reader_Base is abstract tagged limited record
      Owner : Manager := null;
   end record;

   --  Record a servant
   type Message_Handler is record
      For_Servant : Reader_Access;
      Id          : MAT.Events.Internal_Reference;
      Attributes  : MAT.Events.Attribute_Table_Ptr;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   use type MAT.Types.Uint16;

   package Reader_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Message_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Message_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Manager_Base is tagged limited record
      Readers     : Reader_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message);

end MAT.Readers;

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

with System;

with Util.Properties;

with MAT.Types;
with MAT.Events;
package MAT.Readers is

   type Buffer_Type is private;
   type Buffer_Ptr is access Buffer_Type;

   type Message is record
      Kind   : MAT.Events.Event_Type;
      Size   : Natural;
      Buffer : Buffer_Ptr;
   end record;

   -----------------
   --  Abstract servant definition
   -----------------
   --  The Servant is a small proxy that binds the specific message
   --  handlers to the client specific dispatcher.
   type Reader_Base is abstract tagged limited private;
   type Reader_Access is access all Reader_Base'Class;

   procedure Dispatch (For_Servant : in out Reader_Base;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Msg         : in out Message) is abstract;
   --  Dispatch the message

   procedure Bind (For_Servant : in out Reader_Base) is abstract;
   --  Bind the servant with the object adapter to register the
   --  events it recognizes.  This is called once we have all the
   --  information about the structures of events that we can
   --  receive.

   -----------------
   --  Ipc Client Manager
   -----------------
   --  The Manager is a kind of object adapter. It registers a collection
   --  of servants and dispatches incomming messages to those servants.
   type Manager_Base is tagged limited private;
   type Manager is access all Manager_Base'Class;

   --  Register the reader to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Reader (Into   : in out Manager_Base;
                              Reader : in Reader_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Internal_Reference;
                              Model  : in MAT.Events.Attribute_Table_Ptr);

   procedure Register_Servant (Adapter : in Manager;
                               Proxy   : in Reader_Access);
   --  Register the proxy servant in the object adapter.

--     function Get_Manager (Refs : in ClientInfo_Ref_Map) return Manager;
   --  Return the object adapter manager which holds all the servant
   --  for the client.

   procedure Register_Message_Analyzer (Proxy  : in Reader_Access;
                                        Name   : in String;
                                        Id     : in MAT.Events.Internal_Reference;
                                        Model  : in MAT.Events.Attribute_Table;
                                        Table  : out MAT.Events.Attribute_Table_Ptr);
   --  Setup the servant to receive and process messages identified
   --  by Name.

   procedure Dispatch_Message (Client : in out Manager_Base;
                               Msg    : in out Message);

private

   type Buffer_Type is record
      Current : System.Address;
      Start   : System.Address;
      Last    : System.Address;
      Size    : Natural;
      Total   : Natural;
   end record;

   type Reader_Base is abstract tagged limited record
      Owner : Manager := null;
   end record;

   --  Record a servant
   type Message_Handler is record
      For_Servant : Reader_Access;
      Id          : MAT.Events.Internal_Reference;
      Attributes  : MAT.Events.Attribute_Table_Ptr;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   use type MAT.Types.Uint16;

   package Reader_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Message_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Message_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Manager_Base is tagged limited record
      Readers     : Reader_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
   end record;

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message);

end MAT.Readers;

Define the Register_Reader operation

Define the Register_Reader operation


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

   --  ------------------------------
   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   --  ------------------------------
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
   begin
      MAT.Memory.Targets.Initialize (Memory => Target.Memory,
                                     Reader => Reader);
   end Initialize;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Process : out Target_Process_Type_Access) is
   begin
      Process := new Target_Process_Type;
      Process.Pid := Pid;
   end Create_Process;

end MAT.Targets;

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

   --  ------------------------------
   --  Get the console instance.
   --  ------------------------------
   function Console (Target : in Target_Type) return MAT.Consoles.Console_Access is
   begin
      return Target.Console;
   end Console;

   --  ------------------------------
   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   --  ------------------------------
   procedure Initialize (Target : in out Target_Type;
                         Reader : in out MAT.Readers.Manager_Base'Class) is
   begin
      MAT.Memory.Targets.Initialize (Memory => Target.Memory,
                                     Reader => Reader);
   end Initialize;

   --  ------------------------------
   --  Create a process instance to hold and keep track of memory and other information about
   --  the given process ID.
   --  ------------------------------
   procedure Create_Process (Target  : in out Target_Type;
                             Pid     : in MAT.Types.Target_Process_Ref;
                             Process : out Target_Process_Type_Access) is
   begin
      Process := new Target_Process_Type;
      Process.Pid := Pid;
   end Create_Process;

end MAT.Targets;

Implement the Console function to return the current console instance


-----------------------------------------------------------------------
--  util-streams-texts -- Text stream utilities
--  Copyright (C) 2010, 2011, 2012, 2015, 2016, 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.Strings.Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;
with Util.Streams.Buffered;
with Ada.Calendar;
with GNAT.Calendar.Time_IO;
package Util.Streams.Texts is

   --  -----------------------
   --  Print stream
   --  -----------------------
   --  The Print_Stream is an output stream which provides helper methods
   --  for writing text streams.
   type Print_Stream is new Buffered.Output_Buffer_Stream with private;
   type Print_Stream_Access is access all Print_Stream'Class;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : in Output_Stream_Access);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Print_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in String);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Long_Long_Integer);

   --  Write a string on the stream.
--     procedure Write (Stream : in out Print_Stream;
--                      Item   : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write a date on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Calendar.Time;
                    Format : in GNAT.Calendar.Time_IO.Picture_String
                    := GNAT.Calendar.Time_IO.ISO_Date);

   --  Get the output stream content as a string.
   function To_String (Stream : in Buffered.Output_Buffer_Stream'Class) return String;

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Character);

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Wide_Wide_Character);

   --  -----------------------
   --  Reader stream
   --  -----------------------
   --  The Reader_Stream is an input stream which provides helper methods
   --  for reading text streams.
   type Reader_Stream is new Buffered.Input_Buffer_Stream with private;
   type Reader_Stream_Access is access all Reader_Stream'Class;

   --  Initialize the reader to read the input from the input stream given in From.
   procedure Initialize (Stream : in out Reader_Stream;
                         From   : in Input_Stream_Access);

   --  Read an input line from the input stream.  The line is terminated by ASCII.LF.
   --  When Strip is set, the line terminators (ASCII.CR, ASCII.LF) are removed.
   procedure Read_Line (Stream : in out Reader_Stream;
                        Into   : out Ada.Strings.Unbounded.Unbounded_String;
                        Strip  : in Boolean := False);

private

   type Print_Stream is new Buffered.Output_Buffer_Stream with null record;

   type Reader_Stream is new Buffered.Input_Buffer_Stream with null record;

end Util.Streams.Texts;

-----------------------------------------------------------------------
--  util-streams-texts -- Text stream utilities
--  Copyright (C) 2010, 2011, 2012, 2015, 2016, 2017, 2018 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Ada.Strings.Wide_Wide_Unbounded;
with Util.Streams.Buffered;
with Ada.Calendar;
with GNAT.Calendar.Time_IO;
package Util.Streams.Texts is

   --  -----------------------
   --  Print stream
   --  -----------------------
   --  The Print_Stream is an output stream which provides helper methods
   --  for writing text streams.
   type Print_Stream is new Buffered.Output_Buffer_Stream with private;
   type Print_Stream_Access is access all Print_Stream'Class;

   procedure Initialize (Stream : in out Print_Stream;
                         To     : in Output_Stream_Access);

   --  Write a raw character on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Char   : in Character);

   --  Write a wide character on the stream doing some conversion if necessary.
   --  The default implementation translates the wide character to a UTF-8 sequence.
   procedure Write_Wide (Stream : in out Print_Stream;
                         Item   : in Wide_Wide_Character);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in String);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Unbounded.Unbounded_String);

   --  Write a raw string on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Integer);

   --  Write an integer on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Long_Long_Integer);

   --  Write a date on the stream.
   procedure Write (Stream : in out Print_Stream;
                    Item   : in Ada.Calendar.Time;
                    Format : in GNAT.Calendar.Time_IO.Picture_String
                    := GNAT.Calendar.Time_IO.ISO_Date);

   --  Get the output stream content as a string.
   function To_String (Stream : in Buffered.Output_Buffer_Stream'Class) return String;

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Character);

   --  Write a character on the stream.
   procedure Write_Char (Stream : in out Print_Stream'Class;
                         Item   : in Wide_Wide_Character);

   --  -----------------------
   --  Reader stream
   --  -----------------------
   --  The Reader_Stream is an input stream which provides helper methods
   --  for reading text streams.
   type Reader_Stream is new Buffered.Input_Buffer_Stream with private;
   type Reader_Stream_Access is access all Reader_Stream'Class;

   --  Initialize the reader to read the input from the input stream given in From.
   procedure Initialize (Stream : in out Reader_Stream;
                         From   : in Input_Stream_Access);

   --  Read an input line from the input stream.  The line is terminated by ASCII.LF.
   --  When Strip is set, the line terminators (ASCII.CR, ASCII.LF) are removed.
   procedure Read_Line (Stream : in out Reader_Stream;
                        Into   : out Ada.Strings.Unbounded.Unbounded_String;
                        Strip  : in Boolean := False);

private

   type Print_Stream is new Buffered.Output_Buffer_Stream with null record;

   type Reader_Stream is new Buffered.Input_Buffer_Stream with null record;

end Util.Streams.Texts;

Remove commented and unused Write procedure declaration


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

with Util.Log.Loggers;
package body Babel.Strategies.Workers is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Strategies.Workers");

   procedure Start (Worker   : in out Worker_Type;
                    Strategy : in Babel.Strategies.Strategy_Type_Access) is
   begin
      for I in Worker.Workers'Range loop
         Worker.Workers (I).Start (Strategy);
      end loop;
   end Start;

   task body Worker_Task is
      S : Babel.Strategies.Strategy_Type_Access;
   begin
      Log.Info ("Strategy worker is started");
      select
         accept Start (Strategy : in Babel.Strategies.Strategy_Type_Access) do
            S := Strategy;
         end Start;
      or
         terminate;
      end select;
      loop
         begin
            S.Execute;
         exception
            when Babel.Files.File_Fifo.Timeout =>
               Log.Info ("Strategy worker stopped on timeout");
               exit;

            when E : others =>
               Log.Error ("Strategy worker received exception", E);
         end;
      end loop;
   end Worker_Task;

end Babel.Strategies.Workers;

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

with Util.Log.Loggers;
package body Babel.Strategies.Workers is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Babel.Strategies.Workers");

   procedure Start (Worker   : in out Worker_Type;
                    Strategy : in Babel.Strategies.Strategy_Type_Access) is
   begin
      for I in Worker.Workers'Range loop
         Worker.Workers (I).Start (Strategy);
      end loop;
   end Start;

   task body Worker_Task is
      S : Babel.Strategies.Strategy_Type_Access;
   begin
      Log.Info ("Strategy worker is started");
      select
         accept Start (Strategy : in Babel.Strategies.Strategy_Type_Access) do
            S := Strategy;
         end Start;
      or
         terminate;
      end select;
      loop
         begin
            S.Execute;
         exception
            when Babel.Files.Queues.File_Fifo.Timeout =>
               Log.Info ("Strategy worker stopped on timeout");
               exit;

            when E : others =>
               Log.Error ("Strategy worker received exception", E);
         end;
      end loop;
   end Worker_Task;

end Babel.Strategies.Workers;

Fix compilation after code refactoring

Fix compilation after code refactoring


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

--  == Introduction ==
--
--  @include awa-images-modules.ads
--  @include awa-images-services.ads
--  @include awa-images-beans.ads
--  @include images.xml
--  @include image-list.xml
--
--  == Model ==
--  [images/awa_images_model.png]
--
package AWA.Images is

end AWA.Images;

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

--  == Introduction ==
--  The image plugin is an extension to the storage plugin that identifies images and
--  provides thumbnails as well as resizing of the original image.
--
--  @include awa-images-modules.ads
--  @include awa-images-beans.ads
--  @include image-list.xml
--
--  == Model ==
--  [images/awa_images_model.png]
--
package AWA.Images is

end AWA.Images;

Add some documentation

Add some documentation


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

with Ada.Exceptions;

with Util.Log.Loggers;
with Util.Properties.Bundles;
with Util.Beans.Objects;

with ASF.Locales;
with ASF.Applications.Main;
package body ASF.Applications.Messages.Factory is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("ASF.Applications.Messages.Factory");

   --  ------------------------------
   --  Get a localized message.  The message identifier is composed of a resource bundle name
   --  prefix and a bundle key.  The prefix and key are separated by the first '.'.
   --  If the message identifier does not contain any prefix, the default bundle is "messages".
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String) return String is
      Pos    : constant Natural := Util.Strings.Index (Message_Id, '.');
      App    : constant access ASF.Applications.Main.Application'Class := Context.Get_Application;
      Bundle : ASF.Locales.Bundle;
   begin
      if Pos > 0 then
         App.Load_Bundle (Name   => Message_Id (Message_Id'First .. Pos - 1),
                          Locale => "en",
                          Bundle => Bundle);
         return Bundle.Get (Message_Id (Pos + 1 .. Message_Id'Last),
                            Message_Id (Pos + 1 .. Message_Id'Last));
      else
         App.Load_Bundle (Name   => "messages",
                          Locale => "en",
                          Bundle => Bundle);
         return Bundle.Get (Message_Id, Message_Id);
      end if;

   exception
      when E : Util.Properties.Bundles.NO_BUNDLE =>
         Log.Error ("Cannot localize {0}: {1}", Message_Id, Ada.Exceptions.Exception_Message (E));
         return Message_Id;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Summary := Ada.Strings.Unbounded.To_Unbounded_String (Msg);
      Result.Kind    := Severity;
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with one argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 1);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with two argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Param2     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 2);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      Args (2) := Util.Beans.Objects.To_Object (Param2);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with some arguments.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Args       : in ASF.Utils.Object_Array;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Kind := Severity;
      ASF.Utils.Formats.Format (Msg, Args, Result.Summary);
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Param1     : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Param1, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the current faces context.
   --  ------------------------------
   procedure Add_Message (Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      Add_Message (Context.all, Message_Id, Severity);
   end Add_Message;

end ASF.Applications.Messages.Factory;

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

with Ada.Exceptions;

with Util.Log.Loggers;
with Util.Properties.Bundles;
with Util.Beans.Objects;
with Util.Locales;

with ASF.Locales;
with ASF.Applications.Main;
package body ASF.Applications.Messages.Factory is

   use Util.Log;

   Log : constant Loggers.Logger := Loggers.Create ("ASF.Applications.Messages.Factory");

   --  ------------------------------
   --  Get a localized message.  The message identifier is composed of a resource bundle name
   --  prefix and a bundle key.  The prefix and key are separated by the first '.'.
   --  If the message identifier does not contain any prefix, the default bundle is "messages".
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String) return String is
      Pos    : constant Natural := Util.Strings.Index (Message_Id, '.');
      Locale : constant Util.Locales.Locale := Context.Get_Locale;
      App    : constant access ASF.Applications.Main.Application'Class := Context.Get_Application;
      Bundle : ASF.Locales.Bundle;
   begin
      if Pos > 0 then
         App.Load_Bundle (Name   => Message_Id (Message_Id'First .. Pos - 1),
                          Locale => Util.Locales.To_String (Locale),
                          Bundle => Bundle);
         return Bundle.Get (Message_Id (Pos + 1 .. Message_Id'Last),
                            Message_Id (Pos + 1 .. Message_Id'Last));
      else
         App.Load_Bundle (Name   => "messages",
                          Locale => Util.Locales.To_String (Locale),
                          Bundle => Bundle);
         return Bundle.Get (Message_Id, Message_Id);
      end if;

   exception
      when E : Util.Properties.Bundles.NO_BUNDLE =>
         Log.Error ("Cannot localize {0}: {1}", Message_Id, Ada.Exceptions.Exception_Message (E));
         return Message_Id;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Summary := Ada.Strings.Unbounded.To_Unbounded_String (Msg);
      Result.Kind    := Severity;
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with one argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 1);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with two argument.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Param1     : in String;
                         Param2     : in String;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Args : ASF.Utils.Object_Array (1 .. 2);
   begin
      Args (1) := Util.Beans.Objects.To_Object (Param1);
      Args (2) := Util.Beans.Objects.To_Object (Param2);
      return Get_Message (Context, Message_Id, Args, Severity);
   end Get_Message;

   --  ------------------------------
   --  Build a localized message and format the message with some arguments.
   --  ------------------------------
   function Get_Message (Context    : in ASF.Contexts.Faces.Faces_Context'Class;
                         Message_Id : in String;
                         Args       : in ASF.Utils.Object_Array;
                         Severity   : in Messages.Severity := ERROR) return Message is
      Msg    : constant String := Get_Message (Context, Message_Id);
      Result : Message;
   begin
      Result.Kind := Severity;
      ASF.Utils.Formats.Format (Msg, Args, Result.Summary);
      return Result;
   end Get_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Param1     : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Param1, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the faces context.
   --  ------------------------------
   procedure Add_Message (Context    : in out ASF.Contexts.Faces.Faces_Context'Class;
                          Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Msg     : constant Message := Get_Message (Context, Message_Id, Severity);
   begin
      Context.Add_Message (Client_Id => "", Message  => Msg);
   end Add_Message;

   --  ------------------------------
   --  Add a localized global message in the current faces context.
   --  ------------------------------
   procedure Add_Message (Message_Id : in String;
                          Severity   : in Messages.Severity := ERROR) is
      Context : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
   begin
      Add_Message (Context.all, Message_Id, Severity);
   end Add_Message;

end ASF.Applications.Messages.Factory;

Use the context locale to localize the message


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

with System;

with Util.Properties;
with Util.Streams.Buffered;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
package MAT.Readers is

   type Buffer_Type is private;
   type Buffer_Ptr is access all Buffer_Type;

   type Message is record
      Kind   : MAT.Events.Event_Type;
      Size   : Natural;
      Buffer : Buffer_Ptr;
   end record;

   -----------------
   --  Abstract servant definition
   -----------------
   --  The Servant is a small proxy that binds the specific message
   --  handlers to the client specific dispatcher.
   type Reader_Base is abstract tagged limited private;
   type Reader_Access is access all Reader_Base'Class;

   procedure Dispatch (For_Servant : in out Reader_Base;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Frame       : in MAT.Events.Frame_Info;
                       Msg         : in out Message) is abstract;

   -----------------
   --  Ipc Client Manager
   -----------------
   --  The Manager is a kind of object adapter. It registers a collection
   --  of servants and dispatches incomming messages to those servants.
   type Manager_Base is abstract tagged limited private;
   type Manager is access all Manager_Base'Class;

   --  Register the reader to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Reader (Into   : in out Manager_Base;
                              Reader : in Reader_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Internal_Reference;
                              Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Manager_Base;
                               Msg    : in out Message);

   --  Read a message from the stream.
   procedure Read_Message (Client : in out Manager_Base;
                           Msg    : in out Message) is abstract;

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Manager_Base;
                                     Msg    : in out Message);

private

   type Endian_Type is (BIG_ENDIAN, LITTLE_ENDIAN);

   type Buffer_Type is record
      Current : System.Address;
      Start   : System.Address;
      Last    : System.Address;
      Buffer  : Util.Streams.Buffered.Buffer_Access;
      Size    : Natural;
      Total   : Natural;
      Endian  : Endian_Type := LITTLE_ENDIAN;
   end record;

   type Reader_Base is abstract tagged limited record
      Owner : Manager := null;
   end record;

   --  Record a servant
   type Message_Handler is record
      For_Servant : Reader_Access;
      Id          : MAT.Events.Internal_Reference;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   use type MAT.Types.Uint16;

   package Reader_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Message_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Message_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Manager_Base is abstract tagged limited record
      Readers     : Reader_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
   end record;

   --  Read the event data stream headers with the event description.
   --  Configure the reader to analyze the data stream according to the event descriptions.
   procedure Read_Headers (Client : in out Manager_Base;
                           Msg    : in out Message);

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message);

end MAT.Readers;

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

with System;

with Util.Properties;
with Util.Streams.Buffered;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
package MAT.Readers is

   type Buffer_Type is private;
   type Buffer_Ptr is access all Buffer_Type;

   type Message is record
      Kind   : MAT.Events.Event_Type;
      Size   : Natural;
      Buffer : Buffer_Ptr;
   end record;

   -----------------
   --  Abstract servant definition
   -----------------
   --  The Servant is a small proxy that binds the specific message
   --  handlers to the client specific dispatcher.
   type Reader_Base is abstract tagged limited private;
   type Reader_Access is access all Reader_Base'Class;

   procedure Dispatch (For_Servant : in out Reader_Base;
                       Id          : in MAT.Events.Internal_Reference;
                       Params      : in MAT.Events.Const_Attribute_Table_Access;
                       Frame       : in MAT.Events.Frame_Info;
                       Msg         : in out Message) is abstract;

   -----------------
   --  Ipc Client Manager
   -----------------
   --  The Manager is a kind of object adapter. It registers a collection
   --  of servants and dispatches incomming messages to those servants.
   type Manager_Base is abstract tagged limited private;
   type Manager is access all Manager_Base'Class;

   --  Register the reader to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Reader (Into   : in out Manager_Base;
                              Reader : in Reader_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Internal_Reference;
                              Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Manager_Base;
                               Msg    : in out Message);

   --  Read a message from the stream.
   procedure Read_Message (Client : in out Manager_Base;
                           Msg    : in out Message) is abstract;

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Manager_Base;
                                     Msg    : in out Message);

   --  Set the target events.
   procedure Set_Target_Events (Client : in out Manager_Base;
                                Events : out MAT.Events.Targets.Target_Events_Access);

private

   type Endian_Type is (BIG_ENDIAN, LITTLE_ENDIAN);

   type Buffer_Type is record
      Current : System.Address;
      Start   : System.Address;
      Last    : System.Address;
      Buffer  : Util.Streams.Buffered.Buffer_Access;
      Size    : Natural;
      Total   : Natural;
      Endian  : Endian_Type := LITTLE_ENDIAN;
   end record;

   type Reader_Base is abstract tagged limited record
      Owner : Manager := null;
   end record;

   --  Record a servant
   type Message_Handler is record
      For_Servant : Reader_Access;
      Id          : MAT.Events.Internal_Reference;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   use type MAT.Types.Uint16;

   package Reader_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Message_Handler,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Message_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Manager_Base is abstract tagged limited record
      Readers     : Reader_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : aliased MAT.Events.Targets.Target_Events;
   end record;

   --  Read the event data stream headers with the event description.
   --  Configure the reader to analyze the data stream according to the event descriptions.
   procedure Read_Headers (Client : in out Manager_Base;
                           Msg    : in out Message);

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message);

end MAT.Readers;

Declare the Set_Target_Events procedure

Declare the Set_Target_Events procedure


-----------------------------------------------------------------------
--  awa-events-queues-persistents -- AWA Event Queues
--  Copyright (C) 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.Calendar;

with Util.Log.Loggers;

with Util.Serialize.Tools;

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

with ADO;
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.SQL.Query;
      Task_Id  : constant 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;
         Name    : constant String := Msg.Get_Message_Type.Get_Name;
         Event   : Module_Event;

         procedure Action;

         procedure Action is
         begin
            Process (Event);
         end Action;

         procedure Run is new AWA.Services.Contexts.Run_As (Action);

      begin
         Event.Set_Event_Kind (AWA.Events.Find_Event_Index (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;

         Log.Info ("Dispatching event 0} for user{1} session{2}", Name,
                   ADO.Identifier'Image (User.Get_Id), ADO.Identifier'Image (Session.Get_Id));

         --  Run the Process action on behalf of the user associated with the message.
         Run (AWA.Users.Models.User_Ref (User), AWA.Users.Models.Session_Ref (Session));

      exception
         when E : others =>
            Log.Error ("Exception when processing event " & Name, 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_Filter ("o.status = 0 AND o.queue_id = :queue ORDER BY o.priority DESC, "
                        & "o.id ASC LIMIT :max");
      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
      pragma Unreferenced (Props, Context);
      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;
      return new Persistent_Queue '(Name_Length  => Name'Length,
                                    Name         => Name,
                                    Queue        => Queue,
                                    others       => <>);
   end Create_Queue;

end AWA.Events.Queues.Persistents;

-----------------------------------------------------------------------
--  awa-events-queues-persistents -- AWA Event Queues
--  Copyright (C) 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.Calendar;

with Util.Log.Loggers;

with Util.Serialize.Tools;

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

with ADO;
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.SQL.Query;
      Task_Id  : constant 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;
         Name    : constant String := Msg.Get_Message_Type.Get_Name;
         Event   : Module_Event;

         procedure Action;

         procedure Action is
         begin
            Process (Event);
         end Action;

         procedure Run is new AWA.Services.Contexts.Run_As (Action);

      begin
         Event.Set_Event_Kind (AWA.Events.Find_Event_Index (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;

         if not User.Is_Null then
            Log.Info ("Dispatching event {0} for user{1} session{2}", Name,
                      ADO.Identifier'Image (User.Get_Id), ADO.Identifier'Image (Session.Get_Id));
         else
            Log.Info ("Dispatching event {0}", Name);
         end if;

         --  Run the Process action on behalf of the user associated with the message.
         Run (AWA.Users.Models.User_Ref (User), AWA.Users.Models.Session_Ref (Session));

      exception
         when E : others =>
            Log.Error ("Exception when processing event " & Name, 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_Filter ("o.status = 0 AND o.queue_id = :queue ORDER BY o.priority DESC, "
                        & "o.id ASC LIMIT :max");
      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
      pragma Unreferenced (Props, Context);
      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;
      return new Persistent_Queue '(Name_Length  => Name'Length,
                                    Name         => Name,
                                    Queue        => Queue,
                                    others       => <>);
   end Create_Queue;

end AWA.Events.Queues.Persistents;

Fix the crash that could occur when a job not associated with a user is executed


-----------------------------------------------------------------------
--  users - Gives access to the OpenID principal through an Ada bean
--  Copyright (C) 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 ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.OpenID;
with ASF.Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.OpenID;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   procedure Remove_Cookie (Name : in String);

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.OpenID.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.OpenID.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.OpenID.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.OpenID.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (ASF.Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

-----------------------------------------------------------------------
--  users - Gives access to the OpenID principal through an Ada bean
--  Copyright (C) 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 ASF.Contexts.Faces;
with ASF.Contexts.Flash;
with ASF.Sessions;
with ASF.Principals;
with ASF.Cookies;
with ASF.Events.Faces.Actions;
with ASF.Applications.Messages.Factory;

with GNAT.MD5;

with Security.Auth;
with ASF.Security.Filters;

with Util.Strings.Transforms;
package body Users is

   use Ada.Strings.Unbounded;
   use Security.Auth;
   use type ASF.Principals.Principal_Access;
   use type ASF.Contexts.Faces.Faces_Context_Access;

   procedure Remove_Cookie (Name : in String);

   --  ------------------------------
   --  Given an Email address, return the Gravatar link to the user image.
   --  (See http://en.gravatar.com/site/implement/hash/ and
   --  http://en.gravatar.com/site/implement/images/)
   --  ------------------------------
   function Get_Gravatar_Link (Email : in String) return String is
      E : constant String := Util.Strings.Transforms.To_Lower_Case (Email);
      C : constant GNAT.MD5.Message_Digest := GNAT.MD5.Digest (E);
   begin
      return "http://www.gravatar.com/avatar/" & C;
   end Get_Gravatar_Link;

   --  ------------------------------
   --  Get the user information identified by the given name.
   --  ------------------------------
   function Get_Value (From : in User_Info;
                       Name : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Auth.Principal_Access := null;
   begin
      if F /= null then
         S := F.Get_Session;
         if S.Is_Valid then
            P := S.Get_Principal;
            if P /= null then
               U := Security.Auth.Principal'Class (P.all)'Access;
            end if;
         end if;
      end if;
      if Name = "authenticated" then
         return Util.Beans.Objects.To_Object (U /= null);
      end if;
      if U = null then
         return Util.Beans.Objects.Null_Object;
      end if;
      if Name = "email" then
         return Util.Beans.Objects.To_Object (U.Get_Email);
      end if;
      if Name = "language" then
         return Util.Beans.Objects.To_Object (Get_Language (U.Get_Authentication));
      end if;
      if Name = "first_name" then
         return Util.Beans.Objects.To_Object (Get_First_Name (U.Get_Authentication));
      end if;
      if Name = "last_name" then
         return Util.Beans.Objects.To_Object (Get_Last_Name (U.Get_Authentication));
      end if;
      if Name = "full_name" then
         return Util.Beans.Objects.To_Object (Get_Full_Name (U.Get_Authentication));
      end if;
      if Name = "id" then
         return Util.Beans.Objects.To_Object (Get_Claimed_Id (U.Get_Authentication));
      end if;
      if Name = "country" then
         return Util.Beans.Objects.To_Object (Get_Country (U.Get_Authentication));
      end if;
      if Name = "sessionId" then
         return Util.Beans.Objects.To_Object (S.Get_Id);
      end if;
      if Name = "gravatar" then
         return Util.Beans.Objects.To_Object (Get_Gravatar_Link (U.Get_Email));
      end if;

      return Util.Beans.Objects.To_Object (U.Get_Name);
   end Get_Value;

   --  ------------------------------
   --  Helper to send a remove cookie in the current response
   --  ------------------------------
   procedure Remove_Cookie (Name : in String) is
      Ctx : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      C   : ASF.Cookies.Cookie := ASF.Cookies.Create (Name, "");
   begin
      ASF.Cookies.Set_Path (C, Ctx.Get_Request.Get_Context_Path);
      ASF.Cookies.Set_Max_Age (C, 0);
      Ctx.Get_Response.Add_Cookie (Cookie => C);
   end Remove_Cookie;

   --  ------------------------------
   --  Logout by dropping the user session.
   --  ------------------------------
   procedure Logout (From    : in out User_Info;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (From);

      F : constant ASF.Contexts.Faces.Faces_Context_Access := ASF.Contexts.Faces.Current;
      S : ASF.Sessions.Session := F.Get_Session;
      P : ASF.Principals.Principal_Access := null;
      U : Security.Auth.Principal_Access := null;
   begin
      if S.Is_Valid then
         P := S.Get_Principal;
         if P /= null then
            U := Security.Auth.Principal'Class (P.all)'Access;
         end if;
         S.Invalidate;
      end if;
      if U /= null then
         F.Get_Flash.Set_Keep_Messages (True);
         ASF.Applications.Messages.Factory.Add_Message (F.all, "samples.openid_logout_message",
                                                        Get_Full_Name (U.Get_Authentication));
      end if;
      Remove_Cookie (ASF.Security.Filters.SID_COOKIE);
      Outcome := Ada.Strings.Unbounded.To_Unbounded_String ("logout_success");
   end Logout;

   package Logout_Binding is
     new ASF.Events.Faces.Actions.Action_Method.Bind (Bean   => User_Info,
                                                      Method => Logout,
                                                      Name   => "logout");

   Binding_Array : aliased constant Util.Beans.Methods.Method_Binding_Array
     := (1 => Logout_Binding.Proxy'Unchecked_Access);

   --  ------------------------------
   --  This bean provides some methods that can be used in a Method_Expression
   --  ------------------------------
   overriding
   function Get_Method_Bindings (From : in User_Info)
                                 return Util.Beans.Methods.Method_Binding_Array_Access is
      pragma Unreferenced (From);
   begin
      return Binding_Array'Access;
   end Get_Method_Bindings;

end Users;

Use the Security.Auth implementation

Use the Security.Auth implementation