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

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Target_Event_Type;
                          Related    : in MAT.Events.Tools.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Target_Event_Type;
                        Related    : in MAT.Events.Tools.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the PID into a string.
   --  ------------------------------
   function Pid (Value : in MAT.Types.Target_Process_Ref) return String is
   begin
      return Util.Strings.Image (Natural (Value));
   end Pid;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Sec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format an event range description.
   --  ------------------------------
   function Event (First : in MAT.Events.Target_Event_Type;
                   Last  : in MAT.Events.Target_Event_Type) return String is
      use type MAT.Events.Event_Id_Type;

      Id1 : constant String := MAT.Events.Event_Id_Type'Image (First.Id);
      Id2 : constant String := MAT.Events.Event_Id_Type'Image (Last.Id);
   begin
      if First.Id = Last.Id then
         return Id1 (Id1'First + 1 .. Id1'Last);
      else
         return Id1 (Id1'First + 1 .. Id1'Last) & ".." & Id2 (Id2'First + 1 .. Id2'Last);
      end if;
   end Event;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Target_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc";
               else
                  return "realloc";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.MSG_FREE =>
            if Mode = BRIEF then
               return "free";
            else
               return "free(" & Addr (Item.Addr) & "), " & Size (Item.Size);
            end if;

         when MAT.Events.MSG_BEGIN =>
            return "begin";

         when MAT.Events.MSG_END =>
            return "end";

         when MAT.Events.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Target_Event_Type;
                          Related    : in MAT.Events.Tools.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Target_Event_Type;
   begin
      Free_Event := MAT.Events.Tools.Find (Related, MAT.Events.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Tools.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Target_Event_Type;
                        Related    : in MAT.Events.Tools.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Target_Event_Type;
   begin
      Alloc_Event := MAT.Events.Tools.Find (Related, MAT.Events.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Tools.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Target_Event_Type;
                   Related    : in MAT.Events.Tools.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.MSG_END =>
            return "End event";

         when MAT.Events.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

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

   use type MAT.Types.Target_Tick_Ref;

   Hex_Prefix : Boolean := True;

   Conversion : constant String (1 .. 10) := "0123456789";

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String;

   function Event_Malloc (Item       : in MAT.Events.Target_Event_Type;
                          Related    : in MAT.Events.Tools.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   function Event_Free (Item       : in MAT.Events.Target_Event_Type;
                        Related    : in MAT.Events.Tools.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String;

   --  ------------------------------
   --  Format the PID into a string.
   --  ------------------------------
   function Pid (Value : in MAT.Types.Target_Process_Ref) return String is
   begin
      return Util.Strings.Image (Natural (Value));
   end Pid;

   --  ------------------------------
   --  Format the address into a string.
   --  ------------------------------
   function Addr (Value : in MAT.Types.Target_Addr) return String is
      Hex : constant String := MAT.Types.Hex_Image (Value);
   begin
      if Hex_Prefix then
         return "0x" & Hex;
      else
         return Hex;
      end if;
   end Addr;

   --  ------------------------------
   --  Format the size into a string.
   --  ------------------------------
   function Size (Value : in MAT.Types.Target_Size) return String is
      Result : constant String := MAT.Types.Target_Size'Image (Value);
   begin
      if Result (Result'First) = ' ' then
         return Result (Result'First + 1 .. Result'Last);
      else
         return Result;
      end if;
   end Size;

   --  ------------------------------
   --  Format the memory growth size into a string.
   --  ------------------------------
   function Size (Alloced : in MAT.Types.Target_Size;
                  Freed   : in MAT.Types.Target_Size) return String is
      use type MAT.Types.Target_Size;
   begin
      if Alloced > Freed then
         return Size (Alloced - Freed);
      elsif Alloced < Freed then
         return "-" & Size (Freed - Alloced);
      else
         return "=" & Size (Alloced);
      end if;
   end Size;

   --  ------------------------------
   --  Format the time relative to the start time.
   --  ------------------------------
   function Time (Value : in MAT.Types.Target_Tick_Ref;
                  Start : in MAT.Types.Target_Tick_Ref) return String is
      T    : constant MAT.Types.Target_Tick_Ref := Value - Start;
      Sec  : constant MAT.Types.Target_Tick_Ref := T / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := T mod 1_000_000;
      Msec : Natural := Natural (Usec / 1_000);
      Frac : String (1 .. 5);
   begin
      Frac (5) := 's';
      Frac (4) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (3) := Conversion (Msec mod 10 + 1);
      Msec := Msec / 10;
      Frac (2) := Conversion (Msec mod 10 + 1);
      Frac (1) := '.';
      return MAT.Types.Target_Tick_Ref'Image (Sec) & Frac;
   end Time;

   --  ------------------------------
   --  Format the duration in seconds, milliseconds or microseconds.
   --  ------------------------------
   function Duration (Value : in MAT.Types.Target_Tick_Ref) return String is

      Sec  : constant MAT.Types.Target_Tick_Ref := Value / 1_000_000;
      Usec : constant MAT.Types.Target_Tick_Ref := Value mod 1_000_000;
      Msec : constant Natural := Natural (Usec / 1_000);
      Val  : Natural;
      Frac : String (1 .. 5);
   begin
      if Sec = 0 and Msec = 0 then
         return Util.Strings.Image (Integer (Usec)) & "us";
      elsif Sec = 0 then
         Val := Natural (Usec mod 1_000);
         Frac (5) := 's';
         Frac (4) := 'm';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Msec)) & Frac;
      else
         Val := Msec;
         Frac (4) := 's';
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (3) := Conversion (Val mod 10 + 1);
         Val := Val / 10;
         Frac (2) := Conversion (Val mod 10 + 1);
         Frac (1) := '.';
         return Util.Strings.Image (Integer (Sec)) & Frac (1 .. 4);
      end if;
   end Duration;

   function Location (File : in Ada.Strings.Unbounded.Unbounded_String) return String is
      Pos : constant Natural := Ada.Strings.Unbounded.Index (File, "/", Ada.Strings.Backward);
      Len : constant Natural := Ada.Strings.Unbounded.Length (File);
   begin
      if Pos /= 0 then
         return Ada.Strings.Unbounded.Slice (File, Pos + 1, Len);
      else
         return Ada.Strings.Unbounded.To_String (File);
      end if;
   end Location;

   --  ------------------------------
   --  Format a file, line, function information into a string.
   --  ------------------------------
   function Location (File : in Ada.Strings.Unbounded.Unbounded_String;
                      Line : in Natural;
                      Func : in Ada.Strings.Unbounded.Unbounded_String) return String is
   begin
      if Ada.Strings.Unbounded.Length (File) = 0 then
         return Ada.Strings.Unbounded.To_String (Func);
      elsif Line > 0 then
         declare
            Num : constant String := Natural'Image (Line);
         begin
            return Ada.Strings.Unbounded.To_String (Func) & " ("
              & Location (File) & ":" & Num (Num'First + 1 .. Num'Last) & ")";
         end;
      else
         return Ada.Strings.Unbounded.To_String (Func) & " (" & Location (File) & ")";
      end if;
   end Location;

   --  ------------------------------
   --  Format an event range description.
   --  ------------------------------
   function Event (First : in MAT.Events.Target_Event_Type;
                   Last  : in MAT.Events.Target_Event_Type) return String is
      use type MAT.Events.Event_Id_Type;

      Id1 : constant String := MAT.Events.Event_Id_Type'Image (First.Id);
      Id2 : constant String := MAT.Events.Event_Id_Type'Image (Last.Id);
   begin
      if First.Id = Last.Id then
         return Id1 (Id1'First + 1 .. Id1'Last);
      else
         return Id1 (Id1'First + 1 .. Id1'Last) & ".." & Id2 (Id2'First + 1 .. Id2'Last);
      end if;
   end Event;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item : in MAT.Events.Target_Event_Type;
                   Mode : in Format_Type := NORMAL) return String is
      use type MAT.Types.Target_Addr;
   begin
      case Item.Index is
         when MAT.Events.MSG_MALLOC =>
            if Mode = BRIEF then
               return "malloc";
            else
               return "malloc(" & Size (Item.Size) & ") = " & Addr (Item.Addr);
            end if;

         when MAT.Events.MSG_REALLOC =>
            if Mode = BRIEF then
               if Item.Old_Addr = 0 then
                  return "realloc";
               else
                  return "realloc";
               end if;
            else
               if Item.Old_Addr = 0 then
                  return "realloc(0," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               else
                  return "realloc(" & Addr (Item.Old_Addr) & "," & Size (Item.Size) & ") = "
                    & Addr (Item.Addr);
               end if;
            end if;

         when MAT.Events.MSG_FREE =>
            if Mode = BRIEF then
               return "free";
            else
               return "free(" & Addr (Item.Addr) & "), " & Size (Item.Size);
            end if;

         when MAT.Events.MSG_BEGIN =>
            return "begin";

         when MAT.Events.MSG_END =>
            return "end";

         when MAT.Events.MSG_LIBRARY =>
            return "library";

      end case;
   end Event;

   function Event_Malloc (Item       : in MAT.Events.Target_Event_Type;
                          Related    : in MAT.Events.Tools.Target_Event_Vector;
                          Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Free_Event : MAT.Events.Target_Event_Type;
   begin
      Free_Event := MAT.Events.Tools.Find (Related, MAT.Events.MSG_FREE);

      return Size (Item.Size) & " bytes allocated after " & Duration (Item.Time - Start_Time)
        & ", freed " & Duration (Free_Event.Time - Item.Time)
        & " after by event" & MAT.Events.Event_Id_Type'Image (Free_Event.Id)
      ;

   exception
      when MAT.Events.Tools.Not_Found =>
         return Size (Item.Size) & " bytes allocated (never freed)";

   end Event_Malloc;

   function Event_Free (Item       : in MAT.Events.Target_Event_Type;
                        Related    : in MAT.Events.Tools.Target_Event_Vector;
                        Start_Time : in MAT.Types.Target_Tick_Ref) return String is
      Alloc_Event : MAT.Events.Target_Event_Type;
   begin
      Alloc_Event := MAT.Events.Tools.Find (Related, MAT.Events.MSG_MALLOC);

      return Size (Alloc_Event.Size) & " bytes freed after " & Duration (Item.Time - Start_Time)
        & ", alloc'ed for " & Duration (Item.Time - Alloc_Event.Time)
        & " by event" & MAT.Events.Event_Id_Type'Image (Alloc_Event.Id);

   exception
      when MAT.Events.Tools.Not_Found =>
         return Size (Item.Size) & " bytes freed";

   end Event_Free;

   --  ------------------------------
   --  Format a short description of the event.
   --  ------------------------------
   function Event (Item       : in MAT.Events.Target_Event_Type;
                   Related    : in MAT.Events.Tools.Target_Event_Vector;
                   Start_Time : in MAT.Types.Target_Tick_Ref) return String is
   begin
      case Item.Index is
         when MAT.Events.MSG_MALLOC =>
            return Event_Malloc (Item, Related, Start_Time);

         when MAT.Events.MSG_REALLOC =>
            return Size (Item.Size) & " bytes reallocated";

         when MAT.Events.MSG_FREE =>
            return Event_Free (Item, Related, Start_Time);

         when MAT.Events.MSG_BEGIN =>
            return "Begin event";

         when MAT.Events.MSG_END =>
            return "End event";

         when MAT.Events.MSG_LIBRARY =>
            return "Library information event";

      end case;
   end Event;

end MAT.Formats;

Implement the Size function to format a memory growth (alloced/freed)


-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 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;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
private with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns True if the source string starts with the given prefix.
   function Starts_With (Source  : in String;
                         Prefix  : in String) return Boolean;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

-----------------------------------------------------------------------
--  util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 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;
with Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Hashed_Sets;
private with Util.Concurrent.Counters;
package Util.Strings is

   pragma Preelaborate;

   --  Constant string access
   type Name_Access is access constant String;

   --  Compute the hash value of the string.
   function Hash (Key : Name_Access) return Ada.Containers.Hash_Type;

   --  Returns true if left and right strings are equivalent.
   function Equivalent_Keys (Left, Right : Name_Access) return Boolean;

   --  Search for the first occurrence of the character in the string
   --  after the from index.  This implementation is 3-times faster than
   --  the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Index (Source : in String;
                   Char   : in Character;
                   From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the character in the string
   --  before the from index and going backward.
   --  This implementation is 3-times faster than the Ada.Strings.Fixed version.
   --  Returns the index of the first occurrence or 0.
   function Rindex (Source : in String;
                    Ch     : in Character;
                    From   : in Natural := 0) return Natural;

   --  Search for the first occurrence of the pattern in the string.
   function Index (Source  : in String;
                   Pattern : in String;
                   From    : in Positive;
                   Going   : in Ada.Strings.Direction := Ada.Strings.Forward) return Natural;

   --  Returns True if the source string starts with the given prefix.
   function Starts_With (Source  : in String;
                         Prefix  : in String) return Boolean;

   --  Returns True if the source string ends with the given suffix.
   function Ends_With (Source  : in String;
                       Suffix  : in String) return Boolean;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Integer) return String;

   --  Returns Integer'Image (Value) with the possible space stripped.
   function Image (Value : in Long_Long_Integer) return String;

   package String_Access_Map is new Ada.Containers.Hashed_Maps
     (Key_Type        => Name_Access,
      Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Keys => Equivalent_Keys);

   package String_Set is new Ada.Containers.Hashed_Sets
     (Element_Type    => Name_Access,
      Hash            => Hash,
      Equivalent_Elements => Equivalent_Keys);

   --  String reference
   type String_Ref is private;

   --  Create a string reference from a string.
   function To_String_Ref (S : in String) return String_Ref;

   --  Create a string reference from an unbounded string.
   function To_String_Ref (S : in Ada.Strings.Unbounded.Unbounded_String) return String_Ref;

   --  Get the string
   function To_String (S : in String_Ref) return String;

   --  Get the string as an unbounded string
   function To_Unbounded_String (S : in String_Ref) return Ada.Strings.Unbounded.Unbounded_String;

   --  Compute the hash value of the string reference.
   function Hash (Key : in String_Ref) return Ada.Containers.Hash_Type;

   --  Returns true if left and right string references are equivalent.
   function Equivalent_Keys (Left, Right : in String_Ref) return Boolean;
   function "=" (Left, Right : in String_Ref) return Boolean renames Equivalent_Keys;
   function "=" (Left  : in String_Ref;
                 Right : in String) return Boolean;
   function "=" (Left  : in String_Ref;
                 Right : in Ada.Strings.Unbounded.Unbounded_String) return Boolean;

   --  Returns the string length.
   function Length (S : in String_Ref) return Natural;

private
   pragma Inline (To_String_Ref);
   pragma Inline (To_String);

   type String_Record (Len : Natural) is limited record
      Counter : Util.Concurrent.Counters.Counter;
      Str     : String (1 .. Len);
   end record;
   type String_Record_Access is access all String_Record;

   type String_Ref is new Ada.Finalization.Controlled with record
      Str : String_Record_Access := null;
   end record;

   --  Increment the reference counter.
   overriding
   procedure Adjust (Object : in out String_Ref);

   --  Decrement the reference counter and free the allocated string.
   overriding
   procedure Finalize (Object : in out String_Ref);

end Util.Strings;

Declare the Ends_With function

Declare the Ends_With function


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

with Util.Log.Loggers;
with Util.Strings;
with Util.Http.Clients;
with Util.Encoders.HMAC.SHA1;

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package body Security.OAuth.Clients is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.OAuth.Clients");

   --  ------------------------------
   --  Access Token
   --  ------------------------------

   package Id_Random is new Ada.Numerics.Discrete_Random (Interfaces.Unsigned_32);

   protected type Random is

      procedure Generate (Into : out Ada.Streams.Stream_Element_Array);

   private
      --  Random number generator used for ID generation.
      Random       : Id_Random.Generator;

      --  Number of 32-bit random numbers used for the ID generation.
      Id_Size      : Ada.Streams.Stream_Element_Offset := 8;
   end Random;

   protected body Random is

      procedure Generate (Into : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;
         use Interfaces;
      begin
         --  Generate the random sequence.
         for I in 0 .. Id_Size - 1 loop
            declare
               Value : constant Unsigned_32 := Id_Random.Random (Random);
            begin
               Into (4 * I)     := Stream_Element (Value and 16#0FF#);
               Into (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
               Into (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
               Into (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
            end;
         end loop;
      end Generate;

   end Random;

   --  ------------------------------
   --  Get the principal name.  This is the OAuth access token.
   --  ------------------------------
   function Get_Name (From : in Access_Token) return String is
   begin
      return From.Access_Id;
   end Get_Name;

   --  ------------------------------
   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   --  ------------------------------
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String) is
      use Ada.Strings.Unbounded;
   begin
      App.Client_Id := To_Unbounded_String (Client);
      App.Protect   := App.Client_Id & App.Callback;
   end Set_Application_Identifier;

   --  ------------------------------
   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   --  ------------------------------
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String) is
   begin
      App.Secret := Ada.Strings.Unbounded.To_Unbounded_String (Secret);
      App.Key    := App.Secret;
   end Set_Application_Secret;

   --  ------------------------------
   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   --  ------------------------------
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String) is
      use Ada.Strings.Unbounded;
   begin
      App.Callback := To_Unbounded_String (URI);
      App.Protect  := App.Client_Id & App.Callback;
   end Set_Application_Callback;

   --  ------------------------------
   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   --  ------------------------------
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String) is
   begin
      App.Request_URI := Ada.Strings.Unbounded.To_Unbounded_String (URI);
   end Set_Provider_URI;

   --  ------------------------------
   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   --  ------------------------------
   function Get_State (App   : in Application;
                       Nonce : in String) return String is
      use Ada.Strings.Unbounded;

      Data : constant String := Nonce & To_String (App.Protect);
      Hmac : String := Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => To_String (App.Key),
                                                            Data => Data,
                                                            URL  => True);
   begin
      --  Avoid the '=' at end of HMAC since it could be replaced by %C20 which is annoying...
      Hmac (Hmac'Last) := '.';
      return Hmac;
   end Get_State;

   --  ------------------------------
   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   --  ------------------------------
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String is
   begin
      return Security.OAuth.Client_Id
        & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.Redirect_Uri
        & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.Scope
        & "=" & Scope
        & "&"
        & Security.OAuth.State
        & "=" & State;
   end Get_Auth_Params;

   --  ------------------------------
   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   --  ------------------------------
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean is
      Hmac : constant String := Application'Class (App).Get_State (Nonce);
   begin
      return Hmac = State;
   end Is_Valid_State;

   --  ------------------------------
   --  Exchange the OAuth code into an access token.
   --  ------------------------------
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access is
      Client   : Util.Http.Clients.Client;
      Response : Util.Http.Clients.Response;

      Data : constant String
        := Security.OAuth.Grant_Type & "=authorization_code"
          & "&"
        & Security.OAuth.Code & "=" & Code
        & "&"
        & Security.OAuth.Redirect_Uri & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.Client_Id & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.Client_Secret & "=" & Ada.Strings.Unbounded.To_String (App.Secret);
      URI : constant String := Ada.Strings.Unbounded.To_String (App.Request_URI);
   begin
      Log.Info ("Getting access token from {0}", URI);
      Client.Post (URL   => URI,
                   Data  => Data,
                   Reply => Response);
      if Response.Get_Status /= Util.Http.SC_OK then
         Log.Warn ("Cannot get access token from {0}: status is {1}",
                   URI, Natural'Image (Response.Get_Status));
         return null;
      end if;

      --  Decode the response.
      declare
         Content      : constant String := Response.Get_Body;
         Content_Type : constant String := Response.Get_Header ("Content-Type");
         Pos          : Natural := Util.Strings.Index (Content_Type, ';');
         Last         : Natural;
         Expires      : Natural;
      begin
         if Pos = 0 then
            Pos := Content_Type'Last;
         end if;
         Log.Debug ("Content type: {0}", Content_Type);
         Log.Debug ("Data: {0}", Content);

         --  Facebook sends the access token as a 'text/plain' content.
         if Content_Type (Content_Type'First .. Pos) = "text/plain;" then
            Pos := Util.Strings.Index (Content, '=');
            if Pos = 0 then
               Log.Error ("Invalid access token response: '{0}'", Content);
               return null;
            end if;
            if Content (Content'First .. Pos) /= "access_token=" then
               Log.Error ("The 'access_token' parameter is missing in response: '{0}'", Content);
               return null;
            end if;
            Last := Util.Strings.Index (Content, '&', Pos + 1);
            if Last = 0 then
               Log.Error ("Invalid 'access_token' parameter: '{0}'", Content);
               return null;
            end if;
            if Content (Last .. Last + 8) /= "&expires=" then
               Log.Error ("Invalid 'expires' parameter: '{0}'", Content);
               return null;
            end if;
            Expires := Natural'Value (Content (Last + 9 .. Content'Last));
            return Application'Class (App).Create_Access_Token (Content (Pos + 1 .. Last - 1),
                                                                Expires);

         else
            Log.Error ("Content type {0} not supported for access token response", Content_Type);
            Log.Error ("Response: {0}", Content);
            return null;
         end if;
      end;
   end Request_Access_Token;

   --  ------------------------------
   --  Create the access token
   --  ------------------------------
   function Create_Access_Token (App     : in Application;
                                 Token   : in String;
                                 Expires : in Natural) return Access_Token_Access is
      pragma Unreferenced (App, Expires);

   begin
      return new Access_Token '(Len => Token'Length,
                                Access_Id => Token);
   end Create_Access_Token;

end Security.OAuth.Clients;

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

with Util.Log.Loggers;
with Util.Strings;
with Util.Http.Clients;
with Util.Encoders.HMAC.SHA1;

--  The Security.OAuth.Clients package implements the client OAuth 2.0 authorization.
--
--  Note: OAuth 1.0 could be implemented but since it's being deprecated it's not worth doing it.
package body Security.OAuth.Clients is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Security.OAuth.Clients");

   --  ------------------------------
   --  Access Token
   --  ------------------------------

   package Id_Random is new Ada.Numerics.Discrete_Random (Interfaces.Unsigned_32);

   protected type Random is

      procedure Generate (Into : out Ada.Streams.Stream_Element_Array);

   private
      --  Random number generator used for ID generation.
      Random       : Id_Random.Generator;

      --  Number of 32-bit random numbers used for the ID generation.
      Id_Size      : Ada.Streams.Stream_Element_Offset := 8;
   end Random;

   protected body Random is

      procedure Generate (Into : out Ada.Streams.Stream_Element_Array) is
         use Ada.Streams;
         use Interfaces;
      begin
         --  Generate the random sequence.
         for I in 0 .. Id_Size - 1 loop
            declare
               Value : constant Unsigned_32 := Id_Random.Random (Random);
            begin
               Into (4 * I)     := Stream_Element (Value and 16#0FF#);
               Into (4 * I + 1) := Stream_Element (Shift_Right (Value, 8) and 16#0FF#);
               Into (4 * I + 2) := Stream_Element (Shift_Right (Value, 16) and 16#0FF#);
               Into (4 * I + 3) := Stream_Element (Shift_Right (Value, 24) and 16#0FF#);
            end;
         end loop;
      end Generate;

   end Random;

   --  ------------------------------
   --  Get the principal name.  This is the OAuth access token.
   --  ------------------------------
   function Get_Name (From : in Access_Token) return String is
   begin
      return From.Access_Id;
   end Get_Name;

   --  ------------------------------
   --  Get the application identifier.
   --  ------------------------------
   function Get_Application_Identifier (App : in Application) return String is
   begin
      return Ada.Strings.Unbounded.To_String (App.Client_Id);
   end Get_Application_Identifier;

   --  ------------------------------
   --  Set the application identifier used by the OAuth authorization server
   --  to identify the application (for example, the App ID in Facebook).
   --  ------------------------------
   procedure Set_Application_Identifier (App    : in out Application;
                                         Client : in String) is
      use Ada.Strings.Unbounded;
   begin
      App.Client_Id := To_Unbounded_String (Client);
      App.Protect   := App.Client_Id & App.Callback;
   end Set_Application_Identifier;

   --  ------------------------------
   --  Set the application secret defined in the OAuth authorization server
   --  for the application (for example, the App Secret in Facebook).
   --  ------------------------------
   procedure Set_Application_Secret (App    : in out Application;
                                     Secret : in String) is
   begin
      App.Secret := Ada.Strings.Unbounded.To_Unbounded_String (Secret);
      App.Key    := App.Secret;
   end Set_Application_Secret;

   --  ------------------------------
   --  Set the redirection callback that will be used to redirect the user
   --  back to the application after the OAuth authorization is finished.
   --  ------------------------------
   procedure Set_Application_Callback (App : in out Application;
                                       URI : in String) is
      use Ada.Strings.Unbounded;
   begin
      App.Callback := To_Unbounded_String (URI);
      App.Protect  := App.Client_Id & App.Callback;
   end Set_Application_Callback;

   --  ------------------------------
   --  Set the OAuth authorization server URI that the application must use
   --  to exchange the OAuth code into an access token.
   --  ------------------------------
   procedure Set_Provider_URI (App : in out Application;
                               URI : in String) is
   begin
      App.Request_URI := Ada.Strings.Unbounded.To_Unbounded_String (URI);
   end Set_Provider_URI;

   --  ------------------------------
   --  Build a unique opaque value used to prevent cross-site request forgery.
   --  The Nonce parameters is an optional but recommended unique value
   --  used only once.  The state value will be returned back by the OAuth provider.
   --  This protects the <tt>client_id</tt> and <tt>redirect_uri</tt> parameters.
   --  ------------------------------
   function Get_State (App   : in Application;
                       Nonce : in String) return String is
      use Ada.Strings.Unbounded;

      Data : constant String := Nonce & To_String (App.Protect);
      Hmac : String := Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => To_String (App.Key),
                                                            Data => Data,
                                                            URL  => True);
   begin
      --  Avoid the '=' at end of HMAC since it could be replaced by %C20 which is annoying...
      Hmac (Hmac'Last) := '.';
      return Hmac;
   end Get_State;

   --  ------------------------------
   --  Get the authenticate parameters to build the URI to redirect the user to
   --  the OAuth authorization form.
   --  ------------------------------
   function Get_Auth_Params (App : in Application;
                             State : in String;
                             Scope : in String := "") return String is
   begin
      return Security.OAuth.Client_Id
        & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.Redirect_Uri
        & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.Scope
        & "=" & Scope
        & "&"
        & Security.OAuth.State
        & "=" & State;
   end Get_Auth_Params;

   --  ------------------------------
   --  Verify that the State opaque value was created by the Get_State
   --  operation with the given client and redirect URL.
   --  ------------------------------
   function Is_Valid_State (App   : in Application;
                            Nonce : in String;
                            State : in String) return Boolean is
      Hmac : constant String := Application'Class (App).Get_State (Nonce);
   begin
      return Hmac = State;
   end Is_Valid_State;

   --  ------------------------------
   --  Exchange the OAuth code into an access token.
   --  ------------------------------
   function Request_Access_Token (App  : in Application;
                                  Code : in String) return Access_Token_Access is
      Client   : Util.Http.Clients.Client;
      Response : Util.Http.Clients.Response;

      Data : constant String
        := Security.OAuth.Grant_Type & "=authorization_code"
          & "&"
        & Security.OAuth.Code & "=" & Code
        & "&"
        & Security.OAuth.Redirect_Uri & "=" & Ada.Strings.Unbounded.To_String (App.Callback)
        & "&"
        & Security.OAuth.Client_Id & "=" & Ada.Strings.Unbounded.To_String (App.Client_Id)
        & "&"
        & Security.OAuth.Client_Secret & "=" & Ada.Strings.Unbounded.To_String (App.Secret);
      URI : constant String := Ada.Strings.Unbounded.To_String (App.Request_URI);
   begin
      Log.Info ("Getting access token from {0}", URI);
      Client.Post (URL   => URI,
                   Data  => Data,
                   Reply => Response);
      if Response.Get_Status /= Util.Http.SC_OK then
         Log.Warn ("Cannot get access token from {0}: status is {1}",
                   URI, Natural'Image (Response.Get_Status));
         return null;
      end if;

      --  Decode the response.
      declare
         Content      : constant String := Response.Get_Body;
         Content_Type : constant String := Response.Get_Header ("Content-Type");
         Pos          : Natural := Util.Strings.Index (Content_Type, ';');
         Last         : Natural;
         Expires      : Natural;
      begin
         if Pos = 0 then
            Pos := Content_Type'Last;
         end if;
         Log.Debug ("Content type: {0}", Content_Type);
         Log.Debug ("Data: {0}", Content);

         --  Facebook sends the access token as a 'text/plain' content.
         if Content_Type (Content_Type'First .. Pos) = "text/plain;" then
            Pos := Util.Strings.Index (Content, '=');
            if Pos = 0 then
               Log.Error ("Invalid access token response: '{0}'", Content);
               return null;
            end if;
            if Content (Content'First .. Pos) /= "access_token=" then
               Log.Error ("The 'access_token' parameter is missing in response: '{0}'", Content);
               return null;
            end if;
            Last := Util.Strings.Index (Content, '&', Pos + 1);
            if Last = 0 then
               Log.Error ("Invalid 'access_token' parameter: '{0}'", Content);
               return null;
            end if;
            if Content (Last .. Last + 8) /= "&expires=" then
               Log.Error ("Invalid 'expires' parameter: '{0}'", Content);
               return null;
            end if;
            Expires := Natural'Value (Content (Last + 9 .. Content'Last));
            return Application'Class (App).Create_Access_Token (Content (Pos + 1 .. Last - 1),
                                                                Expires);

         else
            Log.Error ("Content type {0} not supported for access token response", Content_Type);
            Log.Error ("Response: {0}", Content);
            return null;
         end if;
      end;
   end Request_Access_Token;

   --  ------------------------------
   --  Create the access token
   --  ------------------------------
   function Create_Access_Token (App     : in Application;
                                 Token   : in String;
                                 Expires : in Natural) return Access_Token_Access is
      pragma Unreferenced (App, Expires);

   begin
      return new Access_Token '(Len => Token'Length,
                                Access_Id => Token);
   end Create_Access_Token;

end Security.OAuth.Clients;

Implement the new function Get_Application_Identifier


-----------------------------------------------------------------------
--  util-stacks -- Simple stack
--  Copyright (C) 2010, 2011, 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.Finalization;
generic
   type Element_Type is private;
   type Element_Type_Access is access all Element_Type;
package Util.Stacks is

   pragma Preelaborate;

   type Stack is limited private;

   --  Get access to the current stack element.
   function Current (Container : in Stack) return Element_Type_Access;

   --  Push an element on top of the stack making the new element the current one.
   procedure Push (Container : in out Stack);

   --  Pop the top element.
   procedure Pop (Container : in out Stack);

   --  Clear the stack.
   procedure Clear (Container : in out Stack);

private
   type Element_Type_Array is array (Natural range <>) of aliased Element_Type;
   type Element_Type_Array_Access is access all Element_Type_Array;

   type Stack is new Ada.Finalization.Limited_Controlled with record
      Current : Element_Type_Access := null;
      Stack   : Element_Type_Array_Access := null;
      Pos     : Natural := 0;
   end record;

   --  Release the stack
   overriding
   procedure Finalize (Obj : in out Stack);

end Util.Stacks;

-----------------------------------------------------------------------
--  util-stacks -- Simple stack
--  Copyright (C) 2010, 2011, 2013, 2022 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Finalization;
generic
   type Element_Type is private;
   type Element_Type_Access is access all Element_Type;
package Util.Stacks is

   pragma Preelaborate;

   type Stack is limited private;

   --  Get access to the current stack element.
   function Current (Container : in Stack) return Element_Type_Access;

   --  Push an element on top of the stack making the new element the current one.
   procedure Push (Container : in out Stack);

   --  Pop the top element.
   procedure Pop (Container : in out Stack);

   --  Clear the stack.
   procedure Clear (Container : in out Stack);

   --  Returns true if the stack is empty.
   function Is_Empty (Container : in out Stack) return Boolean;

private
   type Element_Type_Array is array (Natural range <>) of aliased Element_Type;
   type Element_Type_Array_Access is access all Element_Type_Array;

   type Stack is new Ada.Finalization.Limited_Controlled with record
      Current : Element_Type_Access := null;
      Stack   : Element_Type_Array_Access := null;
      Pos     : Natural := 0;
   end record;

   --  Release the stack
   overriding
   procedure Finalize (Obj : in out Stack);

end Util.Stacks;

Add Is_Empty function

Add Is_Empty function


-----------------------------------------------------------------------
--  awa.users -- User registration, authentication processes
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 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 AWA.Users.Models;
with AWA.Users.Principals;
with AWA.Modules;
with AWA.Events;
with Security.Auth;
with Security.Random;

with ADO;
with ADO.Sessions;

--  == Introduction ==
--  The *users* module provides a *users* service which controls the user data model.
--
--  == Events ==
--  The *users* module exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === user-register ===
--  This event is posted when a new user is registered in the application.
--  It can be used to send a registration email.
--
--  === user-create ===
--  This event is posted when a new user is created.  It can be used to trigger
--  the pre-initialization of the application for the new user.
--
--  === user-lost-password ===
--  This event is posted when a user asks for a password reset through an
--  anonymous form.  It is intended to be used to send the reset password email.
--
--  === user-reset-password ===
--  This event is posted when a user has successfully reset his password.
--  It can be used to send an email.
--
package AWA.Users.Services is

   use AWA.Users.Models;

   package User_Create_Event is new AWA.Events.Definition (Name => "user-create");
   package User_Register_Event is new AWA.Events.Definition (Name => "user-register");
   package User_Lost_Password_Event is new AWA.Events.Definition (Name => "user-lost-password");
   package User_Reset_Password_Event is new AWA.Events.Definition (Name => "user-reset-password");

   NAME : constant String := "User_Service";

   Not_Found  : exception;

   User_Exist : exception;

   --  The session is an authenticate session.  The user authenticated using password or OpenID.
   --  When the user logout, this session is closed as well as any connection session linked to
   --  the authenticate session.
   AUTH_SESSION_TYPE    : constant Integer := 1;

   --  The session is a connection session.  It is linked to an authenticate session.
   --  This session can be closed automatically due to a timeout or user's inactivity.
   --  The AID cookie refers to this connection session to create a new connection session.
   --  Once re-connecting is done, the connection session refered to by AID is marked
   --  as <b<USED_SESSION_TYPE and a new AID cookie with the new connection session is
   --  returned to the user.
   CONNECT_SESSION_TYPE : constant Integer := 0;

   --  The session is a connection session whose associated AID cookie has been used.
   --  This session cannot be used to re-connect a user through the AID cookie.
   USED_SESSION_TYPE    : constant Integer := 2;

   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   function Get_Name_From_Email (Email : in String) return String;

   type User_Service is new AWA.Modules.Module_Manager with private;
   type User_Service_Access is access all User_Service'Class;

   --  Build the authenticate cookie.  The cookie is signed using HMAC-SHA1 with a private key.
   function Get_Authenticate_Cookie (Model : in User_Service;
                                     Id    : in ADO.Identifier)
                                     return String;

   --  Get the authenticate identifier from the cookie.
   --  Verify that the cookie is valid, the signature is correct.
   --  Returns the identified or NO_IDENTIFIER
   function Get_Authenticate_Id (Model  : in User_Service;
                                 Cookie : in String) return ADO.Identifier;

   --  Get the password hash.  The password is signed using HMAC-SHA1 with the salt.
   function Get_Password_Hash (Model    : in User_Service;
                               Password : in String;
                               Salt     : in String)
                               return String;

   --  Create a user in the database with the given user information and
   --  the associated email address.  Verify that no such user already exist.
   --  Raises User_Exist exception if a user with such email is already registered.
   procedure Create_User (Model : in out User_Service;
                          User  : in out User_Ref'Class;
                          Email : in out Email_Ref'Class);

   --  Verify the access key and retrieve the user associated with that key.
   --  Starts a new session associated with the given IP address.
   --  The authenticated user is identified by a principal instance allocated
   --  and returned in Principal.
   --  Raises Not_Found if the access key does not exist.
   procedure Verify_User (Model     : in User_Service;
                          Key       : in String;
                          IpAddr    : in String;
                          Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his email address and his password.
   --  If the user is authenticated, return the user information and
   --  create a new session.  The IP address of the connection is saved
   --  in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Email     : in String;
                           Password  : in String;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his OpenID identifier.  The authentication process
   --  was made by an external OpenID provider.  If the user does not yet exists in
   --  the database, a record is created for him.  Create a new session for the user.
   --  The IP address of the connection is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Auth      : in Security.Auth.Authentication;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with the authenticate cookie generated from a previous authenticate
   --  session.  If the cookie has the correct signature, matches a valid session,
   --  return the user information and create a new session.  The IP address of the connection
   --  is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Cookie    : in String;
                           Ip_Addr   : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Start the lost password process for a user.  Find the user having
   --  the given email address and send that user a password reset key
   --  in an email.
   --  Raises Not_Found exception if no user with such email exist
   procedure Lost_Password (Model : in out User_Service;
                            Email : in String);

   --  Reset the password of the user associated with the secure key.
   --  Raises Not_Found if there is no key or if the user does not have any email
   procedure Reset_Password (Model    : in out User_Service;
                             Key      : in String;
                             Password : in String;
                             IpAddr   : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   --  Verify that the user session identified by Id is valid and still active.
   --  Returns the user and the session objects.
   --  Raises Not_Found if the session does not exist or was closed.
   procedure Verify_Session (Model   : in User_Service;
                             Id      : in ADO.Identifier;
                             User    : out User_Ref'Class;
                             Session : out Session_Ref'Class);

   --  Closes the session identified by Id.  The session identified should refer to
   --  a valid and not closed connection session.
   --  When Logout is set, the authenticate session is also closed.  The connection
   --  sessions associated with the authenticate session are also closed.
   --  Raises Not_Found if the session is invalid or already closed.
   procedure Close_Session (Model  : in User_Service;
                            Id     : in ADO.Identifier;
                            Logout : in Boolean := False);

   procedure Send_Alert (Model : in User_Service;
                         Kind  : in AWA.Events.Event_Index;
                         User  : in User_Ref'Class;
                         Props : in out AWA.Events.Module_Event);

   --  Initialize the user service.
   overriding
   procedure Initialize (Model  : in out User_Service;
                         Module : in AWA.Modules.Module'Class);

private

   function Create_Key (Model  : in out User_Service;
                        Number : in ADO.Identifier) return String;

   procedure Create_Session (Model   : in User_Service;
                             DB      : in out ADO.Sessions.Master_Session;
                             Session : out Session_Ref'Class;
                             User    : in User_Ref'Class;
                             Ip_Addr : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   type User_Service is new AWA.Modules.Module_Manager with record
      Server_Id : Integer := 0;
      Random    : Security.Random.Generator;
      Auth_Key  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end AWA.Users.Services;

-----------------------------------------------------------------------
--  awa.users -- User registration, authentication processes
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 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 AWA.Users.Models;
with AWA.Users.Principals;
with AWA.Modules;
with AWA.Events;
with Security.Auth;
with Security.Random;

with ADO;
with ADO.Sessions;

--  == Introduction ==
--  The *users* module provides a *users* service which controls the user data model.
--
--  == Events ==
--  The *users* module exposes a number of events which are posted when some action
--  are performed at the service level.
--
--  === user-register ===
--  This event is posted when a new user is registered in the application.
--  It can be used to send a registration email.
--
--  === user-create ===
--  This event is posted when a new user is created.  It can be used to trigger
--  the pre-initialization of the application for the new user.
--
--  === user-lost-password ===
--  This event is posted when a user asks for a password reset through an
--  anonymous form.  It is intended to be used to send the reset password email.
--
--  === user-reset-password ===
--  This event is posted when a user has successfully reset his password.
--  It can be used to send an email.
--
package AWA.Users.Services is

   use AWA.Users.Models;

   package User_Create_Event is new AWA.Events.Definition (Name => "user-create");
   package User_Register_Event is new AWA.Events.Definition (Name => "user-register");
   package User_Lost_Password_Event is new AWA.Events.Definition (Name => "user-lost-password");
   package User_Reset_Password_Event is new AWA.Events.Definition (Name => "user-reset-password");

   NAME : constant String := "User_Service";

   Not_Found  : exception;

   User_Exist : exception;

   --  The session is an authenticate session.  The user authenticated using password or OpenID.
   --  When the user logout, this session is closed as well as any connection session linked to
   --  the authenticate session.
   AUTH_SESSION_TYPE    : constant Integer := 1;

   --  The session is a connection session.  It is linked to an authenticate session.
   --  This session can be closed automatically due to a timeout or user's inactivity.
   --  The AID cookie refers to this connection session to create a new connection session.
   --  Once re-connecting is done, the connection session refered to by AID is marked
   --  as <b<USED_SESSION_TYPE and a new AID cookie with the new connection session is
   --  returned to the user.
   CONNECT_SESSION_TYPE : constant Integer := 0;

   --  The session is a connection session whose associated AID cookie has been used.
   --  This session cannot be used to re-connect a user through the AID cookie.
   USED_SESSION_TYPE    : constant Integer := 2;

   --  Get the user name from the email address.
   --  Returns the possible user name from his email address.
   function Get_Name_From_Email (Email : in String) return String;

   type User_Service is new AWA.Modules.Module_Manager with private;
   type User_Service_Access is access all User_Service'Class;

   --  Build the authenticate cookie.  The cookie is signed using HMAC-SHA1 with a private key.
   function Get_Authenticate_Cookie (Model : in User_Service;
                                     Id    : in ADO.Identifier)
                                     return String;

   --  Get the authenticate identifier from the cookie.
   --  Verify that the cookie is valid, the signature is correct.
   --  Returns the identified or NO_IDENTIFIER
   function Get_Authenticate_Id (Model  : in User_Service;
                                 Cookie : in String) return ADO.Identifier;

   --  Get the password hash.  The password is signed using HMAC-SHA1 with the salt.
   function Get_Password_Hash (Model    : in User_Service;
                               Password : in String;
                               Salt     : in String)
                               return String;

   --  Create a user in the database with the given user information and
   --  the associated email address.  Verify that no such user already exist.
   --  Raises User_Exist exception if a user with such email is already registered.
   procedure Create_User (Model : in out User_Service;
                          User  : in out User_Ref'Class;
                          Email : in out Email_Ref'Class);

   --  Verify the access key and retrieve the user associated with that key.
   --  Starts a new session associated with the given IP address.
   --  The authenticated user is identified by a principal instance allocated
   --  and returned in Principal.
   --  Raises Not_Found if the access key does not exist.
   procedure Verify_User (Model     : in User_Service;
                          Key       : in String;
                          IpAddr    : in String;
                          Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his email address and his password.
   --  If the user is authenticated, return the user information and
   --  create a new session.  The IP address of the connection is saved
   --  in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Email     : in String;
                           Password  : in String;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with his OpenID identifier.  The authentication process
   --  was made by an external OpenID provider.  If the user does not yet exists in
   --  the database, a record is created for him.  Create a new session for the user.
   --  The IP address of the connection is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Auth      : in Security.Auth.Authentication;
                           IpAddr    : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Authenticate the user with the authenticate cookie generated from a previous authenticate
   --  session.  If the cookie has the correct signature, matches a valid session,
   --  return the user information and create a new session.  The IP address of the connection
   --  is saved in the session.
   --  Raises Not_Found exception if the user is not recognized
   procedure Authenticate (Model     : in User_Service;
                           Cookie    : in String;
                           Ip_Addr   : in String;
                           Principal : out AWA.Users.Principals.Principal_Access);

   --  Start the lost password process for a user.  Find the user having
   --  the given email address and send that user a password reset key
   --  in an email.
   --  Raises Not_Found exception if no user with such email exist
   procedure Lost_Password (Model : in out User_Service;
                            Email : in String);

   --  Reset the password of the user associated with the secure key.
   --  Raises Not_Found if there is no key or if the user does not have any email
   procedure Reset_Password (Model    : in out User_Service;
                             Key      : in String;
                             Password : in String;
                             IpAddr   : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   --  Verify that the user session identified by Id is valid and still active.
   --  Returns the user and the session objects.
   --  Raises Not_Found if the session does not exist or was closed.
   procedure Verify_Session (Model   : in User_Service;
                             Id      : in ADO.Identifier;
                             User    : out User_Ref'Class;
                             Session : out Session_Ref'Class);

   --  Closes the session identified by Id.  The session identified should refer to
   --  a valid and not closed connection session.
   --  When Logout is set, the authenticate session is also closed.  The connection
   --  sessions associated with the authenticate session are also closed.
   --  Raises Not_Found if the session is invalid or already closed.
   procedure Close_Session (Model  : in User_Service;
                            Id     : in ADO.Identifier;
                            Logout : in Boolean := False);

   --  Create and generate a new access key for the user.  The access key is saved in the
   --  database and it will expire after the expiration delay.
   procedure Create_Access_Key (Model   : in out User_Service;
                                User    : in AWA.Users.Models.User_Ref'Class;
                                Key     : in out AWA.Users.Models.Access_Key_Ref;
                                Expire  : in Duration;
                                Session : in out ADO.Sessions.Master_Session);

   procedure Send_Alert (Model : in User_Service;
                         Kind  : in AWA.Events.Event_Index;
                         User  : in User_Ref'Class;
                         Props : in out AWA.Events.Module_Event);

   --  Initialize the user service.
   overriding
   procedure Initialize (Model  : in out User_Service;
                         Module : in AWA.Modules.Module'Class);

private

   function Create_Key (Model  : in out User_Service;
                        Number : in ADO.Identifier) return String;

   procedure Create_Session (Model   : in User_Service;
                             DB      : in out ADO.Sessions.Master_Session;
                             Session : out Session_Ref'Class;
                             User    : in User_Ref'Class;
                             Ip_Addr : in String;
                             Principal : out AWA.Users.Principals.Principal_Access);

   type User_Service is new AWA.Modules.Module_Manager with record
      Server_Id : Integer := 0;
      Random    : Security.Random.Generator;
      Auth_Key  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end AWA.Users.Services;

Declare the Create_Access_Key procedure to make an access key for a user


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

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

with ADO;
with AWA.Users.Models;
with ASF.Principals;
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;

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

end AWA.Users.Principals;

Fix compilation warnings

Fix compilation warnings