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

with MAT.Readers.Marshaller;
package body MAT.Events.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Events.Probes");

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message_Type);

   P_TIME_SEC         : constant MAT.Events.Internal_Reference := 0;
   P_TIME_USEC        : constant MAT.Events.Internal_Reference := 1;
   P_THREAD_ID        : constant MAT.Events.Internal_Reference := 2;
   P_THREAD_SP        : constant MAT.Events.Internal_Reference := 3;
   P_RUSAGE_MINFLT    : constant MAT.Events.Internal_Reference := 4;
   P_RUSAGE_MAJFLT    : constant MAT.Events.Internal_Reference := 5;
   P_RUSAGE_NVCSW     : constant MAT.Events.Internal_Reference := 6;
   P_RUSAGE_NIVCSW    : constant MAT.Events.Internal_Reference := 7;
   P_FRAME            : constant MAT.Events.Internal_Reference := 8;
   P_FRAME_PC         : constant MAT.Events.Internal_Reference := 9;

   TIME_SEC_NAME      : aliased constant String := "time-sec";
   TIME_USEC_NAME     : aliased constant String := "time-usec";
   THREAD_ID_NAME     : aliased constant String := "thread-id";
   THREAD_SP_NAME     : aliased constant String := "thread-sp";
   RUSAGE_MINFLT_NAME : aliased constant String := "ru-minflt";
   RUSAGE_MAJFLT_NAME : aliased constant String := "ru-majflt";
   RUSAGE_NVCSW_NAME  : aliased constant String := "ru-nvcsw";
   RUSAGE_NIVCSW_NAME : aliased constant String := "ru-nivcsw";
   FRAME_NAME         : aliased constant String := "frame";
   FRAME_PC_NAME      : aliased constant String := "frame-pc";

   Probe_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => TIME_SEC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_TIME_SEC),
      2 => (Name => TIME_USEC_NAME'Access,
             Size => 0,
             Kind => MAT.Events.T_SIZE_T,
             Ref  => P_TIME_USEC),
      3 => (Name => THREAD_ID_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_ID),
      4 => (Name => THREAD_SP_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_SP),
      5 => (Name => FRAME_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME),
      6 => (Name => FRAME_PC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME_PC),
      7 => (Name => RUSAGE_MINFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MINFLT),
      8 => (Name => RUSAGE_MAJFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MAJFLT),
      9 => (Name => RUSAGE_NVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NVCSW),
      10 => (Name => RUSAGE_NIVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NIVCSW)
     );

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

   --  ------------------------------
   --  Initialize the manager instance.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type) is
   begin
      Manager.Events := new MAT.Events.Targets.Target_Events;
      Manager.Frames := MAT.Frames.Create_Root;
   end Initialize;

   --  ------------------------------
   --  Register the probe 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_Probe (Into   : in out Probe_Manager_Type;
                              Probe  : in Probe_Type_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Targets.Probe_Index_Type;
                              Model  : in MAT.Events.Const_Attribute_Table_Access) is
      Handler : Probe_Handler;
   begin
      Handler.Probe := Probe;
      Handler.Id    := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := null;
      Into.Probes.Insert (Name, Handler);
   end Register_Probe;

   --  ------------------------------
   --  Get the target events.
   --  ------------------------------
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access is
   begin
      return Client.Events;
   end Get_Target_Events;

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Tick_Ref;

      Count     : Natural := 0;
      Time_Sec  : MAT.Types.Uint32  := 0;
      Time_Usec : MAT.Types.Uint32 := 0;
      Frame     : constant access MAT.Events.Frame_Info := Client.Frame;
   begin
      Client.Event.Thread := 0;
      Frame.Stack  := 0;
      Frame.Cur_Depth := 0;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            case Def.Ref is
               when P_TIME_SEC =>
                  Time_Sec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_TIME_USEC =>
                  Time_Usec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_ID =>
                  Client.Event.Thread := MAT.Types.Target_Thread_Ref
                    (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind));

               when P_THREAD_SP =>
                  Frame.Stack := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when P_FRAME =>
                  Count := Natural (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg,
                                    Def.Kind));

               when P_FRAME_PC =>
                  for I in 1 .. Count loop
                     if Count < Frame.Depth then
                        Frame.Frame (I) := MAT.Readers.Marshaller.Get_Target_Addr (Msg,
                                                                                Def.Kind);
                     end if;
                  end loop;

               when others =>
                  null;

            end case;
         end;
      end loop;
      --  Convert the time in usec to make computation easier.
      Client.Event.Time := MAT.Types.Target_Tick_Ref (Time_Sec) * 1_000_000;
      Client.Event.Time := Client.Event.Time + MAT.Types.Target_Tick_Ref (Time_Usec);
      Frame.Cur_Depth := Count;
   end Read_Probe;

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type) is
      use type MAT.Events.Attribute_Table_Ptr;
      use type MAT.Events.Targets.Target_Events_Access;

      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Log.Get_Level = Util.Log.DEBUG_LEVEL then
         Log.Debug ("Dispatch message {0} - size {1}",
                    MAT.Types.Uint16'Image (Event),
                    Natural'Image (Msg.Size));
      end if;

      if not Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         if Client.Probe /= null then
            Read_Probe (Client, Msg);
         end if;
         declare
            Handler : constant Probe_Handler := Handler_Maps.Element (Pos);
         begin
            Client.Event.Event := Event;
            Client.Event.Index := Handler.Id;
            Handler.Probe.Extract (Handler.Mapping.all'Access, Msg, Client.Event);
            MAT.Frames.Insert (Frame  => Client.Frames,
                               Pc     => Client.Frame.Frame (1 .. Client.Frame.Cur_Depth),
                               Result => Client.Event.Frame);
            Client.Events.Insert (Client.Event);
            Handler.Probe.Execute (Client.Event);
         end;
      end if;

   exception
      when E : others =>
         Log.Error ("Exception while processing event " & MAT.Types.Uint16'Image (Event), E, True);
   end Dispatch_Message;

   --  ------------------------------
   --  Read an event definition from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message_Type) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Probe_Maps.Cursor := Client.Probes.Find (Name);
      Frame : Probe_Handler;

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler);

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler) is
         pragma Unreferenced (Key);
      begin
         Client.Handlers.Insert (Event, Element);
      end Add_Handler;

   begin
      Log.Debug ("Read event definition {0} with {1} attributes",
                 Name, MAT.Types.Uint16'Image (Count));

      if Name = "start" then
         Frame.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         Frame.Attributes := Probe_Attributes'Access;
         Client.Probe := Frame.Mapping;
      else
         Frame.Mapping := null;
      end if;
      for I in 1 .. Natural (Count) loop
         declare
            Name : constant String := MAT.Readers.Marshaller.Get_String (Msg);
            Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler) is
               pragma Unreferenced (Key);
               use type MAT.Events.Attribute_Table_Ptr;
            begin
               if Element.Mapping = null then
                  Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
               end if;
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                     if Size = 1 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT8;
                     elsif Size = 2 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT16;
                     elsif Size = 4 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     elsif Size = 8 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT64;
                     else
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     end if;
                  end if;
               end loop;
            end Read_Attribute;

            use type MAT.Events.Attribute_Table_Ptr;
         begin
            if Probe_Maps.Has_Element (Pos) then
               Client.Probes.Update_Element (Pos, Read_Attribute'Access);
            end if;
            if Frame.Mapping /= null then
               Read_Attribute ("start", Frame);
            end if;
         end;
      end loop;
      if Probe_Maps.Has_Element (Pos) then
         Client.Probes.Update_Element (Pos, Add_Handler'Access);
      end if;
   end Read_Definition;

   --  ------------------------------
   --  Read a list of event definitions from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message) is
      Count : MAT.Types.Uint16;
   begin
      if Client.Frame = null then
         Client.Frame := new MAT.Events.Frame_Info (512);
      end if;
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;

   exception
      when E : MAT.Readers.Marshaller.Buffer_Underflow_Error =>
         Log.Error ("Not enough data in the message", E, True);

   end Read_Event_Definitions;

end MAT.Events.Probes;

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

with MAT.Readers.Marshaller;
package body MAT.Events.Probes is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("MAT.Events.Probes");

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message_Type);

   P_TIME_SEC         : constant MAT.Events.Internal_Reference := 0;
   P_TIME_USEC        : constant MAT.Events.Internal_Reference := 1;
   P_THREAD_ID        : constant MAT.Events.Internal_Reference := 2;
   P_THREAD_SP        : constant MAT.Events.Internal_Reference := 3;
   P_RUSAGE_MINFLT    : constant MAT.Events.Internal_Reference := 4;
   P_RUSAGE_MAJFLT    : constant MAT.Events.Internal_Reference := 5;
   P_RUSAGE_NVCSW     : constant MAT.Events.Internal_Reference := 6;
   P_RUSAGE_NIVCSW    : constant MAT.Events.Internal_Reference := 7;
   P_FRAME            : constant MAT.Events.Internal_Reference := 8;
   P_FRAME_PC         : constant MAT.Events.Internal_Reference := 9;

   TIME_SEC_NAME      : aliased constant String := "time-sec";
   TIME_USEC_NAME     : aliased constant String := "time-usec";
   THREAD_ID_NAME     : aliased constant String := "thread-id";
   THREAD_SP_NAME     : aliased constant String := "thread-sp";
   RUSAGE_MINFLT_NAME : aliased constant String := "ru-minflt";
   RUSAGE_MAJFLT_NAME : aliased constant String := "ru-majflt";
   RUSAGE_NVCSW_NAME  : aliased constant String := "ru-nvcsw";
   RUSAGE_NIVCSW_NAME : aliased constant String := "ru-nivcsw";
   FRAME_NAME         : aliased constant String := "frame";
   FRAME_PC_NAME      : aliased constant String := "frame-pc";

   Probe_Attributes : aliased constant MAT.Events.Attribute_Table :=
     (1 => (Name => TIME_SEC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_TIME_SEC),
      2 => (Name => TIME_USEC_NAME'Access,
             Size => 0,
             Kind => MAT.Events.T_SIZE_T,
             Ref  => P_TIME_USEC),
      3 => (Name => THREAD_ID_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_ID),
      4 => (Name => THREAD_SP_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_THREAD_SP),
      5 => (Name => FRAME_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME),
      6 => (Name => FRAME_PC_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_FRAME_PC),
      7 => (Name => RUSAGE_MINFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MINFLT),
      8 => (Name => RUSAGE_MAJFLT_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_MAJFLT),
      9 => (Name => RUSAGE_NVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NVCSW),
      10 => (Name => RUSAGE_NIVCSW_NAME'Access,
            Size => 0,
            Kind => MAT.Events.T_SIZE_T,
            Ref  => P_RUSAGE_NIVCSW)
     );

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

   --  ------------------------------
   --  Initialize the manager instance.
   --  ------------------------------
   overriding
   procedure Initialize (Manager : in out Probe_Manager_Type) is
   begin
      Manager.Events := new MAT.Events.Targets.Target_Events;
      Manager.Frames := MAT.Frames.Create_Root;
   end Initialize;

   --  ------------------------------
   --  Register the probe 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_Probe (Into   : in out Probe_Manager_Type;
                              Probe  : in Probe_Type_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Targets.Probe_Index_Type;
                              Model  : in MAT.Events.Const_Attribute_Table_Access) is
      Handler : Probe_Handler;
   begin
      Handler.Probe := Probe;
      Handler.Id    := Id;
      Handler.Attributes  := Model;
      Handler.Mapping     := null;
      Into.Probes.Insert (Name, Handler);
   end Register_Probe;

   --  ------------------------------
   --  Get the target events.
   --  ------------------------------
   function Get_Target_Events (Client : in Probe_Manager_Type)
                               return MAT.Events.Targets.Target_Events_Access is
   begin
      return Client.Events;
   end Get_Target_Events;

   procedure Read_Probe (Client : in out Probe_Manager_Type;
                         Msg    : in out MAT.Readers.Message) is
      use type MAT.Types.Target_Tick_Ref;

      Count     : Natural := 0;
      Time_Sec  : MAT.Types.Uint32  := 0;
      Time_Usec : MAT.Types.Uint32 := 0;
      Frame     : constant access MAT.Events.Frame_Info := Client.Frame;
   begin
      Client.Event.Thread := 0;
      Frame.Stack  := 0;
      Frame.Cur_Depth := 0;
      for I in Client.Probe'Range loop
         declare
            Def : MAT.Events.Attribute renames Client.Probe (I);
         begin
            case Def.Ref is
               when P_TIME_SEC =>
                  Time_Sec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_TIME_USEC =>
                  Time_Usec := MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind);

               when P_THREAD_ID =>
                  Client.Event.Thread := MAT.Types.Target_Thread_Ref
                    (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg, Def.Kind));

               when P_THREAD_SP =>
                  Frame.Stack := MAT.Readers.Marshaller.Get_Target_Addr (Msg, Def.Kind);

               when P_FRAME =>
                  Count := Natural (MAT.Readers.Marshaller.Get_Target_Uint32 (Msg,
                                    Def.Kind));

               when P_FRAME_PC =>
                  for I in 1 .. Count loop
                     if Count < Frame.Depth then
                        Frame.Frame (I) := MAT.Readers.Marshaller.Get_Target_Addr (Msg,
                                                                                Def.Kind);
                     end if;
                  end loop;

               when others =>
                  null;

            end case;
         end;
      end loop;
      --  Convert the time in usec to make computation easier.
      Client.Event.Time := MAT.Types.Target_Tick_Ref (Time_Sec) * 1_000_000;
      Client.Event.Time := Client.Event.Time + MAT.Types.Target_Tick_Ref (Time_Usec);
      Frame.Cur_Depth := Count;

   exception
      when E : others =>
         Log.Error ("Marshaling error, frame count {0}", Natural'Image (Count));
         raise;

   end Read_Probe;

   procedure Dispatch_Message (Client : in out Probe_Manager_Type;
                               Msg    : in out MAT.Readers.Message_Type) is
      use type MAT.Events.Attribute_Table_Ptr;
      use type MAT.Events.Targets.Target_Events_Access;

      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Handler_Maps.Cursor := Client.Handlers.Find (Event);
   begin
      if Log.Get_Level = Util.Log.DEBUG_LEVEL then
         Log.Debug ("Dispatch message {0} - size {1}",
                    MAT.Types.Uint16'Image (Event),
                    Natural'Image (Msg.Size));
      end if;

      if not Handler_Maps.Has_Element (Pos) then
         --  Message is not handled, skip it.
         null;
      else
         if Client.Probe /= null then
            Read_Probe (Client, Msg);
         end if;
         declare
            Handler : constant Probe_Handler := Handler_Maps.Element (Pos);
         begin
            Client.Event.Event := Event;
            Client.Event.Index := Handler.Id;
            Handler.Probe.Extract (Handler.Mapping.all'Access, Msg, Client.Event);
            MAT.Frames.Insert (Frame  => Client.Frames,
                               Pc     => Client.Frame.Frame (1 .. Client.Frame.Cur_Depth),
                               Result => Client.Event.Frame);
            Handler.Probe.Execute (Client.Event);
            Client.Events.Insert (Client.Event);
         end;
      end if;

   exception
      when E : others =>
         Log.Error ("Exception while processing event " & MAT.Types.Uint16'Image (Event), E, True);
   end Dispatch_Message;

   --  ------------------------------
   --  Read an event definition from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Definition (Client : in out Probe_Manager_Type;
                              Msg    : in out MAT.Readers.Message_Type) is
      Name  : constant String := MAT.Readers.Marshaller.Get_String (Msg);
      Event : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Pos   : constant Probe_Maps.Cursor := Client.Probes.Find (Name);
      Frame : Probe_Handler;

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler);

      procedure Add_Handler (Key     : in String;
                             Element : in out Probe_Handler) is
         pragma Unreferenced (Key);
      begin
         Client.Handlers.Insert (Event, Element);
      end Add_Handler;

   begin
      Log.Debug ("Read event definition {0} with {1} attributes",
                 Name, MAT.Types.Uint16'Image (Count));

      if Name = "start" then
         Frame.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
         Frame.Attributes := Probe_Attributes'Access;
         Client.Probe := Frame.Mapping;
      else
         Frame.Mapping := null;
      end if;
      for I in 1 .. Natural (Count) loop
         declare
            Name : constant String := MAT.Readers.Marshaller.Get_String (Msg);
            Size : constant MAT.Types.Uint16 := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler);

            procedure Read_Attribute (Key     : in String;
                                      Element : in out Probe_Handler) is
               pragma Unreferenced (Key);
               use type MAT.Events.Attribute_Table_Ptr;
            begin
               if Element.Mapping = null then
                  Element.Mapping := new MAT.Events.Attribute_Table (1 .. Natural (Count));
               end if;
               for J in Element.Attributes'Range loop
                  if Element.Attributes (J).Name.all = Name then
                     Element.Mapping (I) := Element.Attributes (J);
                     if Size = 1 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT8;
                     elsif Size = 2 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT16;
                     elsif Size = 4 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     elsif Size = 8 then
                        Element.Mapping (I).Kind := MAT.Events.T_UINT64;
                     else
                        Element.Mapping (I).Kind := MAT.Events.T_UINT32;
                     end if;
                  end if;
               end loop;
            end Read_Attribute;

            use type MAT.Events.Attribute_Table_Ptr;
         begin
            if Probe_Maps.Has_Element (Pos) then
               Client.Probes.Update_Element (Pos, Read_Attribute'Access);
            end if;
            if Frame.Mapping /= null then
               Read_Attribute ("start", Frame);
            end if;
         end;
      end loop;
      if Probe_Maps.Has_Element (Pos) then
         Client.Probes.Update_Element (Pos, Add_Handler'Access);
      end if;
   end Read_Definition;

   --  ------------------------------
   --  Read a list of event definitions from the stream and configure the reader.
   --  ------------------------------
   procedure Read_Event_Definitions (Client : in out Probe_Manager_Type;
                                     Msg    : in out MAT.Readers.Message) is
      Count : MAT.Types.Uint16;
   begin
      if Client.Frame = null then
         Client.Frame := new MAT.Events.Frame_Info (512);
      end if;
      Client.Version := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);
      Count := MAT.Readers.Marshaller.Get_Uint16 (Msg.Buffer);

      Log.Info ("Read event stream version {0} with {1} definitions",
                MAT.Types.Uint16'Image (Client.Version),
                MAT.Types.Uint16'Image (Count));
      for I in 1 .. Count loop
         Read_Definition (Client, Msg);
      end loop;

   exception
      when E : MAT.Readers.Marshaller.Buffer_Underflow_Error =>
         Log.Error ("Not enough data in the message", E, True);

   end Read_Event_Definitions;

end MAT.Events.Probes;

Insert the event after calling the Execute to let the handler update the event (useful for the free event to retrieve the size of memory allocation and get the correct value in the event list)


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

--  == Auth ==
--  The Security.Auth package implements an authentication framework that is
--  suitable for OpenID 2.0, OAuth 2.0 and later for OpenID Connect.  It allows an application
--  to authenticate users using an external authorization server such as Google, Facebook,
--  Google +, Twitter and others.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  See OpenID Connect Standard 1.0
--  http://openid.net/specs/openid-connect-standard-1_0.html
--
--  See Facebook API: The Login Flow for Web (without JavaScript SDK)
--  https://developers.facebook.com/docs/facebook-login/login-flow-for-web-no-jssdk/
--
--  Despite their subtle differences, all these authentication frameworks share almost
--  a common flow.  The API provided by Security.Auth defines an abstraction suitable
--  for all these frameworks.
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The Authentication manager must be declared and configured.
--
--    Mgr   : Security.Auth.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the Auth realm and set the authentication return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify",
--                    Realm     => "openid");
--
--  After this initialization, the authentication manager can be used in the authentication
--  process.
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.Auth.End_Point;
--    Assoc    : constant Security.Auth.Association_Access := new Security.Auth.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc      : Association_Access := ...;  --  Get the association saved in the session.
--    Credential : Security.Auth.Authentication;
--    Params     : Auth_Params;
--
--  The auth manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Credential);
--    if Security.Auth.Get_Status (Credential) = Security.Auth.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Credential);
--
package Security.Auth is

   --  Use an authentication server implementing OpenID 2.0.
   PROVIDER_OPENID   : constant String := "openid";

   --  Use the Facebook OAuth 2.0 - draft 12 authentication server.
   PROVIDER_FACEBOOK : constant String := "facebook";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  Auth provider
   --  ------------------------------
   --  The End_Point represents the authentication provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The association contains the shared secret between the relying party
   --  and the authentication provider.  The association can be cached and reused to authenticate
   --  different users using the same authentication provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Get the provider.
   function Get_Provider (Assoc : in Association) return String;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  Authentication result
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

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

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  Authentication Manager
   --  ------------------------------
   --  The Manager provides the core operations for the authentication process.
   type Manager is tagged limited private;

   --  Initialize the authentication realm.
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the authentication provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.  The discover step may do nothing for
   --  authentication providers based on OAuth.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the authentication provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Provider     : Unbounded_String;
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager_Access is access all Manager'Class;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Provider  : Unbounded_String;
      Delegate  : Manager_Access;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String);

end Security.Auth;

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

--  == Auth ==
--  The Security.Auth package implements an authentication framework that is
--  suitable for OpenID 2.0, OAuth 2.0 and later for OpenID Connect.  It allows an application
--  to authenticate users using an external authorization server such as Google, Facebook,
--  Google +, Twitter and others.
--
--  See OpenID Authentication 2.0 - Final
--  http://openid.net/specs/openid-authentication-2_0.html
--
--  See OpenID Connect Standard 1.0
--  http://openid.net/specs/openid-connect-standard-1_0.html
--
--  See Facebook API: The Login Flow for Web (without JavaScript SDK)
--  https://developers.facebook.com/docs/facebook-login/login-flow-for-web-no-jssdk/
--
--  Despite their subtle differences, all these authentication frameworks share almost
--  a common flow.  The API provided by Security.Auth defines an abstraction suitable
--  for all these frameworks.
--
--  There are basically two steps that an application must implement:
--
--    * Discovery: to resolve and use the OpenID provider and redirect the user to the
--      provider authentication form.
--    * Verify: to decode the authentication and check its result.
--
--  [http://ada-security.googlecode.com/svn/wiki/OpenID.png]
--
--  The authentication process is the following:
--
--    * The application should redirect the user to the authentication URL.
--    * The OpenID provider authenticate the user and redirects the user to the callback CB.
--    * The association is decoded from the callback parameter.
--    * The Verify procedure is called with the association to check the result and
--      obtain the authentication results.
--
--  === Initialization ===
--  The initialization process must be done before each two steps (discovery and verify).
--  The Authentication manager must be declared and configured.
--
--    Mgr   : Security.Auth.Manager;
--
--  For the configuration, the Initialize procedure is called to configure
--  the Auth realm and set the authentication return callback URL.  The return callback
--  must be a valid URL that is based on the realm.  Example:
--
--    Mgr.Initialize (Name      => "http://app.site.com/auth",
--                    Return_To => "http://app.site.com/auth/verify",
--                    Realm     => "openid");
--
--  After this initialization, the authentication manager can be used in the authentication
--  process.
--
--  @include security-auth-openid.ads
--  @include security-auth-oauth.ads
--
--  === Discovery: creating the authentication URL ===
--  The first step is to create an authentication URL to which the user must be redirected.
--  In this step, we have to create an OpenID manager, discover the OpenID provider,
--  do the association and get an End_Point.  The OpenID provider is specified as an
--  URL, below is an example for Google OpenID:
--
--    Provider : constant String := "https://www.google.com/accounts/o8/id";
--    OP       : Security.Auth.End_Point;
--    Assoc    : constant Security.Auth.Association_Access := new Security.Auth.Association;
--
--  The following steps are performed:
--
--    * The Discover procedure is called to retrieve from the OpenID provider the XRDS
--      stream and identify the provider.  An End_Point is returned in <tt>OP</tt>.
--    * The Associate procedure is called to make the association with the End_Point.
--      The Association record holds session, and authentication.
--
--    Mgr.Discover (Provider, OP);  --  Yadis discovery (get the XRDS file).
--    Mgr.Associate (OP, Assoc.all);--  Associate and get an end-point with a key.
--
--  After this first step, you must manage to save the association in the HTTP session.
--  Then you must redirect to the authentication URL that is obtained by using:
--
--    Auth_URL : constant String := Mgr.Get_Authentication_URL (OP, Assoc.all);
--
--  === Verify: acknowledge the authentication in the callback URL ===
--  The second step is done when the user has finished the authentication successfully or not.
--  For this step, the application must get back the association that was saved in the session.
--  It must also prepare a parameters object that allows the OpenID framework to get the
--  URI parameters from the return callback.
--
--    Assoc      : Association_Access := ...;  --  Get the association saved in the session.
--    Credential : Security.Auth.Authentication;
--    Params     : Auth_Params;
--
--  The auth manager must be initialized and the Verify procedure is called with
--  the association, parameters and the authentication result.  The Get_Status function
--  must be used to check that the authentication succeeded.
--
--    Mgr.Verify (Assoc.all, Params, Credential);
--    if Security.Auth.Get_Status (Credential) = Security.Auth.AUTHENTICATED then ...  -- Success.
--
--  === Principal creation ===
--  After the user is successfully authenticated, a user principal can be created and saved in
--  the session.  The user principal can then be used to assign permissions to that user and
--  enforce the application permissions using the security policy manger.
--
--    P : Security.Auth.Principal_Access := Security.Auth.Create_Principal (Credential);
--
package Security.Auth is

   --  Use an authentication server implementing OpenID 2.0.
   PROVIDER_OPENID   : constant String := "openid";

   --  Use the Facebook OAuth 2.0 - draft 12 authentication server.
   PROVIDER_FACEBOOK : constant String := "facebook";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

   function Get_Parameter (Params : in Parameters;
                           Name   : in String) return String is abstract;

   --  ------------------------------
   --  Auth provider
   --  ------------------------------
   --  The End_Point represents the authentication provider that will authenticate
   --  the user.
   type End_Point is private;

   function To_String (OP : End_Point) return String;

   --  ------------------------------
   --  Association
   --  ------------------------------
   --  The association contains the shared secret between the relying party
   --  and the authentication provider.  The association can be cached and reused to authenticate
   --  different users using the same authentication provider.  The association also has an
   --  expiration date.
   type Association is private;

   --  Get the provider.
   function Get_Provider (Assoc : in Association) return String;

   --  Dump the association as a string (for debugging purposes)
   function To_String (Assoc : Association) return String;

   type Auth_Result is (AUTHENTICATED, CANCEL, SETUP_NEEDED, UNKNOWN, INVALID_SIGNATURE);

   --  ------------------------------
   --  Authentication result
   --  ------------------------------
   --
   type Authentication is private;

   --  Get the email address
   function Get_Email (Auth : in Authentication) return String;

   --  Get the user first name.
   function Get_First_Name (Auth : in Authentication) return String;

   --  Get the user last name.
   function Get_Last_Name (Auth : in Authentication) return String;

   --  Get the user full name.
   function Get_Full_Name (Auth : in Authentication) return String;

   --  Get the user identity.
   function Get_Identity (Auth : in Authentication) return String;

   --  Get the user claimed identity.
   function Get_Claimed_Id (Auth : in Authentication) return String;

   --  Get the user language.
   function Get_Language (Auth : in Authentication) return String;

   --  Get the user country.
   function Get_Country (Auth : in Authentication) return String;

   --  Get the result of the authentication.
   function Get_Status (Auth : in Authentication) return Auth_Result;

   --  ------------------------------
   --  Default principal
   --  ------------------------------
   type Principal is new Security.Principal with private;
   type Principal_Access is access all Principal'Class;

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

   --  Get the user email address.
   function Get_Email (From : in Principal) return String;

   --  Get the authentication data.
   function Get_Authentication (From : in Principal) return Authentication;

   --  Create a principal with the given authentication results.
   function Create_Principal (Auth : in Authentication) return Principal_Access;

   --  ------------------------------
   --  Authentication Manager
   --  ------------------------------
   --  The Manager provides the core operations for the authentication process.
   type Manager is tagged limited private;

   --  Initialize the authentication realm.
   procedure Initialize (Realm     : in out Manager;
                         Params    : in Parameters'Class;
                         Provider  : in String := PROVIDER_OPENID);

   --  Discover the authentication provider that must be used to authenticate the user.
   --  The Name can be an URL or an alias that identifies the provider.
   --  A cached OpenID provider can be returned.  The discover step may do nothing for
   --  authentication providers based on OAuth.
   --  (See OpenID Section 7.3 Discovery)
   procedure Discover (Realm  : in out Manager;
                       Name   : in String;
                       Result : out End_Point);

   --  Associate the application (relying party) with the authentication provider.
   --  The association can be cached.
   --  (See OpenID Section 8 Establishing Associations)
   procedure Associate (Realm  : in out Manager;
                        OP     : in End_Point;
                        Result : out Association);

   --  Get the authentication URL to which the user must be redirected for authentication
   --  by the authentication server.
   function Get_Authentication_URL (Realm : in Manager;
                                    OP    : in End_Point;
                                    Assoc : in Association) return String;

   --  Verify the authentication result
   procedure Verify (Realm   : in out Manager;
                     Assoc   : in Association;
                     Request : in Parameters'Class;
                     Result  : out Authentication);

private

   use Ada.Strings.Unbounded;

   type Association is record
      Provider     : Unbounded_String;
      Session_Type : Unbounded_String;
      Assoc_Type   : Unbounded_String;
      Assoc_Handle : Unbounded_String;
      Mac_Key      : Unbounded_String;
      Expired      : Ada.Calendar.Time;
   end record;

   type Authentication is record
      Status     : Auth_Result;
      Identity   : Unbounded_String;
      Claimed_Id : Unbounded_String;
      Email      : Unbounded_String;
      Full_Name  : Unbounded_String;
      First_Name : Unbounded_String;
      Last_Name  : Unbounded_String;
      Language   : Unbounded_String;
      Country    : Unbounded_String;
      Gender     : Unbounded_String;
      Timezone   : Unbounded_String;
      Nickname   : Unbounded_String;
   end record;

   type End_Point is record
      URL        : Unbounded_String;
      Alias      : Unbounded_String;
      Expired    : Ada.Calendar.Time;
   end record;

   type Manager_Access is access all Manager'Class;

   type Manager is new Ada.Finalization.Limited_Controlled with record
      Provider  : Unbounded_String;
      Delegate  : Manager_Access;
   end record;

   type Principal is new Security.Principal with record
      Auth : Authentication;
   end record;

   procedure Set_Result (Result  : in out Authentication;
                         Status  : in Auth_Result;
                         Message : in String);

end Security.Auth;

Add some documentation

Add some documentation


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

with Util.Streams.Buffered;
package body Util.Measures is

   ISO_DATE_TIME : constant GNAT.Calendar.Time_IO.Picture_String := "%Y-%m-%d %H:%M:%S";

   procedure Free is
     new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Measure, Measure_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (String, String_Access);

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

   function Format (D : in Duration) return String;

   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String;

   --  ------------------------------
   --  Disable collecting measures on the measure set.
   --  ------------------------------
   procedure Disable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := False;
   end Disable;

   --  ------------------------------
   --  Enable collecting measures on the measure set.
   --  ------------------------------
   procedure Enable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := True;
   end Enable;

   --  ------------------------------
   --  Set the per-thread measure set.
   --  ------------------------------
   procedure Set_Current (Measures : in Measure_Set_Access) is
   begin
      Task_Context.Set_Value (Measures);
   end Set_Current;

   --  ------------------------------
   --  Get the per-thread measure set.
   --  ------------------------------
   function Get_Current return Measure_Set_Access is
   begin
      return Task_Context.Value;
   end Get_Current;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  When writing the measures, the measure set is cleared.  It is safe
   --  to write measures while other measures are being collected.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in out Util.Streams.Texts.Print_Stream'Class) is

      use Util.Streams.Buffered;

      procedure Dump_XML (Item : in Measure_Access);

      procedure Dump_XML (Item : in Measure_Access) is
         Total : constant String := Format (Item.Time);
         Time  : constant String := Format (Item.Time / Item.Count);
      begin
         Stream.Write ("<time count=""");
         Stream.Write (Item.Count);
         Stream.Write (""" time=""");
         Stream.Write (Time (Time'First + 1 .. Time'Last));
         if Item.Count > 1 then
            Stream.Write (""" total=""");
            Stream.Write (Total (Total'First + 1 .. Total'Last));
         end if;
         Stream.Write (""" title=""");
         Util.Streams.Texts.TR.Escape_Java_Script (Into => Buffered_Stream (Stream),
                                                   Content => Item.Name.all);
         Stream.Write ("""/>");
         Stream.Write (ASCII.LF);
      end Dump_XML;

      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;

   begin
      Measures.Data.Steal_Map (Buckets, TS, TE);
      Stream.Write ("<measures title=""");
      Util.Streams.Texts.TR.Escape_Java_Script (Into    => Buffered_Stream (Stream),
                                                Content => Title);
      Stream.Write (""" start=""");
      Stream.Write (TS, ISO_DATE_TIME);
      Stream.Write (""" end=""");
      Stream.Write (TE, ISO_DATE_TIME);
      Stream.Write (""">");
      if Buckets /= null then
         begin
            for I in Buckets'Range loop
               declare
                  Next : Measure_Access;
                  Node : Measure_Access := Buckets (I);
               begin
                  while Node /= null loop
                     Dump_XML (Node);
                     Free (Node.Name);
                     Next := Node.Next;
                     Free (Node);
                     Node := Next;
                  end loop;
               end;
            end loop;

         exception
            when others =>
               Free (Buckets);
               raise;
         end;
         Free (Buckets);
      end if;
      Stream.Write ("</measures>");
   end Write;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in Ada.Text_IO.File_Type) is

      Buffer : aliased Util.Streams.Buffered.Buffered_Stream;
      Output : Util.Streams.Texts.Print_Stream;

   begin
      Buffer.Initialize (Size => 128 * 1024);
      Output.Initialize (To => Buffer'Unchecked_Access);
      Write (Measures, Title, Output);
      Output.Flush;
      Ada.Text_IO.Put_Line (Stream, Util.Streams.Texts.To_String (Buffer));
   end Write;

   --  ------------------------------
   --  Dump  an XML result with the measures in a file.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Path     : in String) is
      File : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => File, Name => Path);
      Write (Measures, Title, File);
      Ada.Text_IO.Close (File);
   exception
      when others =>
         if Ada.Text_IO.Is_Open (File) then
            Ada.Text_IO.Close (File);
         end if;
         raise;
   end Write;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the per-thread measure set under the given measure
   --  title.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     Title : in String;
                     Count : in Positive := 1) is
      Measures : constant Measure_Set_Access := Task_Context.Value;
   begin
      if Measures /= null and then Measures.Enabled then
         Report (Measures.all, S, Title, Count);
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the measure set under the given measure title.
   --  ------------------------------
   procedure Report (Measures : in out Measure_Set;
                     S        : in out Stamp;
                     Title    : in String;
                     Count    : in Positive := 1) is
      use Ada.Calendar;
   begin
      if Measures.Enabled then
         declare
            D : constant Duration := Ada.Calendar.Clock - S.Start;
         begin
            Measures.Data.Add (Title, D, Count);
         end;
         S.Start := Ada.Calendar.Clock;
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  The report is written in the file with the given title.  The duration is
   --  expressed in the unit defined in <tt>Unit</tt>.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     File  : in out Ada.Text_IO.File_Type;
                     Title : in String;
                     Unit  : in Unit_Type := Microseconds) is
      use Ada.Calendar;

      D : constant Duration := Ada.Calendar.Clock - S.Start;
   begin
      Ada.Text_IO.Put (File, Title);
      Ada.Text_IO.Put (File, Format (D, Unit));
      S.Start := Ada.Calendar.Clock;
   end Report;

   protected body Measure_Data is

      --  ------------------------------
      --  Get the measures and clear to start a new set of measures.
      --  Return in Time_Start and Time_End the period of time.
      --  ------------------------------
      procedure Steal_Map (Result     : out Buckets_Access;
                           Time_Start : out Ada.Calendar.Time;
                           Time_End   : out Ada.Calendar.Time) is
      begin
         Result     := Buckets;
         Time_Start := Start;
         Start      := Ada.Calendar.Clock;
         Time_End   := Start;
         Buckets    := null;
      end Steal_Map;

      --  ------------------------------
      --  Add the measure
      --  ------------------------------
      procedure Add (Title : in String;
                     D     : in Duration;
                     Count : in Positive := 1) is

         use Ada.Containers;
         use Ada.Calendar;

         Pos  : Hash_Type;
         Node : Measure_Access;
      begin
         if Buckets = null then
            Buckets := new Buckets_Type (0 .. 256);
         end if;
         Pos := Ada.Strings.Hash (Title) mod Buckets'Length;
         Node := Buckets (Pos);
         while Node /= null loop
            if Node.Name'Length = Title'Length
              and then Node.Name.all = Title
            then
               Node.Count := Node.Count + Count;
               Node.Time := Node.Time + D;
               return;
            end if;
            Node := Node.Next;
         end loop;
         Buckets (Pos) := new Measure '(Name => new String '(Title),
                                        Time  => D,
                                        Count => Count,
                                        Next  => Buckets (Pos));
      end Add;

   end Measure_Data;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D : in Duration) return String is
   begin
      if D < 0.000_001 then
         return Duration'Image (D * 1_000_000_000) (1 .. 6) & " ns";
      elsif D < 0.001 then
         return Duration'Image (D * 1_000_000) (1 .. 6) & " us";
      elsif D < 1.0 then
         return Duration'Image (D * 1_000) (1 .. 6) & " ms";
      else
         return Duration'Image (D) (1 .. 6) & " s";
      end if;
   end Format;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String is
   begin
      case Unit is
         when Seconds =>
            return Duration'Image (D);

         when Milliseconds =>
            return Duration'Image (D * 1_000);

         when Microseconds =>
            return Duration'Image (D * 1_000_000);

         when Nanoseconds =>
            return Duration'Image (D * 1_000_000_000);

      end case;
   end Format;

   --  ------------------------------
   --  Finalize the measures and release the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Measures : in out Measure_Set) is
      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;
   begin
      --  When deleting the measure set, we have to release the buckets and measures
      --  that were allocated.  We could call Write but we don't know where
      --  the measures have to be written.
      Measures.Data.Steal_Map (Buckets, TS, TE);
      if Buckets /= null then
         for I in Buckets'Range loop
            declare
               Next : Measure_Access;
               Node : Measure_Access := Buckets (I);
            begin
               while Node /= null loop
                  Free (Node.Name);
                  Next := Node.Next;
                  Free (Node);
                  Node := Next;
               end loop;
            end;
         end loop;
         Free (Buckets);
      end if;
   end Finalize;

end Util.Measures;

-----------------------------------------------------------------------
--  measure -- Benchmark tools
--  Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2015, 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.Task_Attributes;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
with GNAT.Calendar.Time_IO;

with Util.Streams.Buffered;
with Util.Streams.Texts.TR;
package body Util.Measures is

   ISO_DATE_TIME : constant GNAT.Calendar.Time_IO.Picture_String := "%Y-%m-%d %H:%M:%S";

   procedure Free is
     new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Measure, Measure_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (String, String_Access);

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

   function Format (D : in Duration) return String;

   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String;

   --  ------------------------------
   --  Disable collecting measures on the measure set.
   --  ------------------------------
   procedure Disable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := False;
   end Disable;

   --  ------------------------------
   --  Enable collecting measures on the measure set.
   --  ------------------------------
   procedure Enable (Measures : in out Measure_Set) is
   begin
      Measures.Enabled := True;
   end Enable;

   --  ------------------------------
   --  Set the per-thread measure set.
   --  ------------------------------
   procedure Set_Current (Measures : in Measure_Set_Access) is
   begin
      Task_Context.Set_Value (Measures);
   end Set_Current;

   --  ------------------------------
   --  Get the per-thread measure set.
   --  ------------------------------
   function Get_Current return Measure_Set_Access is
   begin
      return Task_Context.Value;
   end Get_Current;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  When writing the measures, the measure set is cleared.  It is safe
   --  to write measures while other measures are being collected.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in out Util.Streams.Texts.Print_Stream'Class) is

      use Util.Streams.Buffered;

      procedure Dump_XML (Item : in Measure_Access);

      procedure Dump_XML (Item : in Measure_Access) is
         Total : constant String := Format (Item.Time);
         Time  : constant String := Format (Item.Time / Item.Count);
      begin
         Stream.Write ("<time count=""");
         Stream.Write (Item.Count);
         Stream.Write (""" time=""");
         Stream.Write (Time (Time'First + 1 .. Time'Last));
         if Item.Count > 1 then
            Stream.Write (""" total=""");
            Stream.Write (Total (Total'First + 1 .. Total'Last));
         end if;
         Stream.Write (""" title=""");
         Util.Streams.Texts.TR.Escape_Java_Script (Into => Stream,
                                                   Content => Item.Name.all);
         Stream.Write ("""/>");
         Stream.Write (ASCII.LF);
      end Dump_XML;

      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;

   begin
      Measures.Data.Steal_Map (Buckets, TS, TE);
      Stream.Write ("<measures title=""");
      Util.Streams.Texts.TR.Escape_Java_Script (Into    => Stream,
                                                Content => Title);
      Stream.Write (""" start=""");
      Stream.Write (TS, ISO_DATE_TIME);
      Stream.Write (""" end=""");
      Stream.Write (TE, ISO_DATE_TIME);
      Stream.Write (""">");
      if Buckets /= null then
         begin
            for I in Buckets'Range loop
               declare
                  Next : Measure_Access;
                  Node : Measure_Access := Buckets (I);
               begin
                  while Node /= null loop
                     Dump_XML (Node);
                     Free (Node.Name);
                     Next := Node.Next;
                     Free (Node);
                     Node := Next;
                  end loop;
               end;
            end loop;

         exception
            when others =>
               Free (Buckets);
               raise;
         end;
         Free (Buckets);
      end if;
      Stream.Write ("</measures>");
   end Write;

   --  ------------------------------
   --  Dump an XML result with the measures collected by the measure set.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Stream   : in Ada.Text_IO.File_Type) is

      Buffer : aliased Util.Streams.Buffered.Buffered_Stream;
      Output : Util.Streams.Texts.Print_Stream;

   begin
      Buffer.Initialize (Size => 128 * 1024);
      Output.Initialize (To => Buffer'Unchecked_Access);
      Write (Measures, Title, Output);
      Output.Flush;
      Ada.Text_IO.Put_Line (Stream, Util.Streams.Texts.To_String (Buffer));
   end Write;

   --  ------------------------------
   --  Dump  an XML result with the measures in a file.
   --  ------------------------------
   procedure Write (Measures : in out Measure_Set;
                    Title    : in String;
                    Path     : in String) is
      File : Ada.Text_IO.File_Type;
   begin
      Ada.Text_IO.Create (File => File, Name => Path);
      Write (Measures, Title, File);
      Ada.Text_IO.Close (File);
   exception
      when others =>
         if Ada.Text_IO.Is_Open (File) then
            Ada.Text_IO.Close (File);
         end if;
         raise;
   end Write;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the per-thread measure set under the given measure
   --  title.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     Title : in String;
                     Count : in Positive := 1) is
      Measures : constant Measure_Set_Access := Task_Context.Value;
   begin
      if Measures /= null and then Measures.Enabled then
         Report (Measures.all, S, Title, Count);
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  Collect the result in the measure set under the given measure title.
   --  ------------------------------
   procedure Report (Measures : in out Measure_Set;
                     S        : in out Stamp;
                     Title    : in String;
                     Count    : in Positive := 1) is
      use Ada.Calendar;
   begin
      if Measures.Enabled then
         declare
            D : constant Duration := Ada.Calendar.Clock - S.Start;
         begin
            Measures.Data.Add (Title, D, Count);
         end;
         S.Start := Ada.Calendar.Clock;
      end if;
   end Report;

   --  ------------------------------
   --  Report the time spent between the stamp creation and this method call.
   --  The report is written in the file with the given title.  The duration is
   --  expressed in the unit defined in <tt>Unit</tt>.
   --  ------------------------------
   procedure Report (S     : in out Stamp;
                     File  : in out Ada.Text_IO.File_Type;
                     Title : in String;
                     Unit  : in Unit_Type := Microseconds) is
      use Ada.Calendar;

      D : constant Duration := Ada.Calendar.Clock - S.Start;
   begin
      Ada.Text_IO.Put (File, Title);
      Ada.Text_IO.Put (File, Format (D, Unit));
      S.Start := Ada.Calendar.Clock;
   end Report;

   protected body Measure_Data is

      --  ------------------------------
      --  Get the measures and clear to start a new set of measures.
      --  Return in Time_Start and Time_End the period of time.
      --  ------------------------------
      procedure Steal_Map (Result     : out Buckets_Access;
                           Time_Start : out Ada.Calendar.Time;
                           Time_End   : out Ada.Calendar.Time) is
      begin
         Result     := Buckets;
         Time_Start := Start;
         Start      := Ada.Calendar.Clock;
         Time_End   := Start;
         Buckets    := null;
      end Steal_Map;

      --  ------------------------------
      --  Add the measure
      --  ------------------------------
      procedure Add (Title : in String;
                     D     : in Duration;
                     Count : in Positive := 1) is

         use Ada.Containers;
         use Ada.Calendar;

         Pos  : Hash_Type;
         Node : Measure_Access;
      begin
         if Buckets = null then
            Buckets := new Buckets_Type (0 .. 256);
         end if;
         Pos := Ada.Strings.Hash (Title) mod Buckets'Length;
         Node := Buckets (Pos);
         while Node /= null loop
            if Node.Name'Length = Title'Length
              and then Node.Name.all = Title
            then
               Node.Count := Node.Count + Count;
               Node.Time := Node.Time + D;
               return;
            end if;
            Node := Node.Next;
         end loop;
         Buckets (Pos) := new Measure '(Name => new String '(Title),
                                        Time  => D,
                                        Count => Count,
                                        Next  => Buckets (Pos));
      end Add;

   end Measure_Data;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D : in Duration) return String is
   begin
      if D < 0.000_001 then
         return Duration'Image (D * 1_000_000_000) (1 .. 6) & " ns";
      elsif D < 0.001 then
         return Duration'Image (D * 1_000_000) (1 .. 6) & " us";
      elsif D < 1.0 then
         return Duration'Image (D * 1_000) (1 .. 6) & " ms";
      else
         return Duration'Image (D) (1 .. 6) & " s";
      end if;
   end Format;

   --  ------------------------------
   --  Format the duration in a time in 'ns', 'us', 'ms' or seconds.
   --  ------------------------------
   function Format (D    : in Duration;
                    Unit : in Unit_Type) return String is
   begin
      case Unit is
         when Seconds =>
            return Duration'Image (D);

         when Milliseconds =>
            return Duration'Image (D * 1_000);

         when Microseconds =>
            return Duration'Image (D * 1_000_000);

         when Nanoseconds =>
            return Duration'Image (D * 1_000_000_000);

      end case;
   end Format;

   --  ------------------------------
   --  Finalize the measures and release the storage.
   --  ------------------------------
   overriding
   procedure Finalize (Measures : in out Measure_Set) is
      Buckets : Buckets_Access;
      TS, TE  : Ada.Calendar.Time;
   begin
      --  When deleting the measure set, we have to release the buckets and measures
      --  that were allocated.  We could call Write but we don't know where
      --  the measures have to be written.
      Measures.Data.Steal_Map (Buckets, TS, TE);
      if Buckets /= null then
         for I in Buckets'Range loop
            declare
               Next : Measure_Access;
               Node : Measure_Access := Buckets (I);
            begin
               while Node /= null loop
                  Free (Node.Name);
                  Next := Node.Next;
                  Free (Node);
                  Node := Next;
               end loop;
            end;
         end loop;
         Free (Buckets);
      end if;
   end Finalize;

end Util.Measures;

Update to import the Util.Streams.Texts.TR package explicitly