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

package body Natools.S_Expressions.Generic_Caches is

   --------------------
   -- Tree Interface --
   --------------------

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null)
   is
      N : Node_Access;
   begin
      case Kind is
         when Atom_Node =>
            N := new Node'(Kind => Atom_Node,
              Parent | Next => null, Data => Data);
         when List_Node =>
            N := new Node'(Kind => List_Node, Parent | Next | Child => null);
      end case;

      if Exp.Root = null then
         pragma Assert (Exp.Last = null);
         Exp.Root := N;
      else
         pragma Assert (Exp.Last /= null);

         if Exp.Opening then
            pragma Assert (Exp.Last.Kind = List_Node);
            pragma Assert (Exp.Last.Child = null);
            Exp.Last.Child := N;
            N.Parent := Exp.Last;
         else
            pragma Assert (Exp.Last.Next = null);
            Exp.Last.Next := N;
            N.Parent := Exp.Last.Parent;
         end if;
      end if;

      Exp.Last := N;
      Exp.Opening := Kind = List_Node;
   end Append;

   procedure Close_List (Exp : in out Tree) is
   begin
      if Exp.Opening then
         Exp.Opening := False;
      elsif Exp.Last /= null and then Exp.Last.Parent /= null then
         Exp.Last := Exp.Last.Parent;
      end if;
   end Close_List;

   function Create_Tree return Tree is
   begin
      return Tree'(Ada.Finalization.Limited_Controlled
        with Root | Last => null, Opening => False);
   end Create_Tree;

   function Duplicate (Source : Tree) return Tree is
      function Dup_List (First, Parent : Node_Access) return Node_Access;
      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access;

      New_Last : Node_Access := null;

      function Dup_List (First, Parent : Node_Access) return Node_Access is
         Source : Node_Access := First;
         Result, Target : Node_Access;
      begin
         if First = null then
            return null;
         end if;
         Result := Dup_Node (First, Parent);
         Target := Result;
         loop
            Source := Source.Next;
            exit when Source = null;
            Target.Next := Dup_Node (Source, Parent);
            Target := Target.Next;
         end loop;
         return Result;
      end Dup_List;

      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access
      is
         Result : Node_Access;
      begin
         case N.Kind is
            when Atom_Node =>
               Result := new Node'(Kind => Atom_Node,
                 Parent => Parent,
                 Next => null,
                 Data => new Atom'(N.Data.all));
            when List_Node =>
               Result := new Node'(Kind => List_Node,
                 Parent => Parent,
                 Next => null,
                 Child => null);
               Result.Child := Dup_List (N.Child, Result);
         end case;

         if N = Source.Last then
            New_Last := Result;
         end if;

         return Result;
      end Dup_Node;
   begin
      return Result : Tree do
         Result.Root := Dup_List (Source.Root, null);
         pragma Assert ((New_Last = null) = (Source.Last = null));
         Result.Last := New_Last;
         Result.Opening := Source.Opening;
      end return;
   end Duplicate;

   overriding procedure Finalize (Object : in out Tree) is
      procedure List_Free (First : in out Node_Access);

      procedure List_Free (First : in out Node_Access) is
         Next : Node_Access := First;
         Cur : Node_Access;
      begin
         while Next /= null loop
            Cur := Next;

            case Cur.Kind is
               when Atom_Node =>
                  Unchecked_Free (Cur.Data);
               when List_Node =>
                  List_Free (Cur.Child);
            end case;

            Next := Cur.Next;
            Unchecked_Free (Cur);
         end loop;

         First := null;
      end List_Free;
   begin
      List_Free (Object.Root);
      Object.Last := null;
      Object.Opening := False;
   end Finalize;

   -----------------------
   -- Writing Interface --
   -----------------------

   function Duplicate (Cache : Reference) return Reference is
      function Dup_Tree return Tree;

      function Dup_Tree return Tree is
      begin
         return Duplicate (Cache.Exp.Query.Data.all);
      end Dup_Tree;
   begin
      return Reference'(Exp => Trees.Create (Dup_Tree'Access));
   end Duplicate;

   -----------------------
   -- Printer Interface --
   -----------------------

   overriding procedure Open_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Append (List_Node);
   end Open_List;

   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom) is
   begin
      if Output.Exp.Is_Empty then
         Output.Exp.Replace (Create_Tree'Access);
      end if;

      Output.Exp.Update.Data.Append (Atom_Node, new Atom'(Data));
   end Append_Atom;

   overriding procedure Close_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Close_List;
   end Close_List;

   -------------------------
   -- Reading Subprograms --
   -------------------------

   function First (Cache : Reference'Class) return Cursor is
      N : Node_Access;
   begin
      if Cache.Exp.Is_Empty then
         return Cursor'(others => <>);
      else
         N := Cache.Exp.Query.Data.Root;
         pragma Assert (N /= null);
         return Cursor'(Exp => Cache.Exp, Position => N,
           Opening => N.Kind = List_Node);
      end if;
   end First;

   --------------------------
   -- Descriptor Interface --
   --------------------------

   overriding function Current_Event (Object : in Cursor)
     return Events.Event is
   begin
      if Object.Position = null then
         return Events.End_Of_Input;
      end if;

      case Object.Position.Kind is
         when Atom_Node =>
            return Events.Add_Atom;
         when List_Node =>
            if Object.Opening then
               return Events.Open_List;
            else
               return Events.Close_List;
            end if;
      end case;
   end Current_Event;

   overriding function Current_Atom (Object : in Cursor) return Atom is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      return Object.Position.Data.all;
   end Current_Atom;

   overriding function Current_Level (Object : in Cursor) return Natural is
      Result : Natural := 0;
      N : Node_Access := Object.Position;
   begin
      if Object.Position /= null
        and then Object.Position.Kind = List_Node
        and then Object.Opening
      then
         Result := Result + 1;
      end if;

      while N /= null loop
         Result := Result + 1;
         N := N.Parent;
      end loop;

      return Natural'Max (Result, 1) - 1;
   end Current_Level;

   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Process.all (Object.Position.Data.all);
   end Query_Atom;

   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count)
   is
      Transferred : Count;
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Length := Object.Position.Data'Length;
      Transferred := Count'Min (Data'Length, Length);
      Data (Data'First .. Data'First + Transferred - 1)
        := Object.Position.Data (Object.Position.Data'First
             .. Object.Position.Data'First + Transferred - 1);
   end Read_Atom;

   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event) is
   begin
      if Object.Position = null then
         Event := Events.Error;
         return;
      end if;

      if Object.Opening then
         pragma Assert (Object.Position.Kind = List_Node);
         if Object.Position.Child = null then
            Object.Opening := False;
         else
            pragma Assert (Object.Position.Child.Parent = Object.Position);
            Object.Position := Object.Position.Child;
            Object.Opening := Object.Position.Kind = List_Node;
         end if;
      elsif Object.Position.Next /= null then
         pragma Assert (Object.Position.Next.Parent = Object.Position.Parent);
         Object.Position := Object.Position.Next;
         Object.Opening := Object.Position.Kind = List_Node;
      elsif Object.Position.Parent /= null then
         pragma Assert (Object.Position.Parent.Kind = List_Node);
         Object.Position := Object.Position.Parent;
         Object.Opening := False;
      else
         Object.Position := null;
      end if;

      Event := Object.Current_Event;
   end Next;

end Natools.S_Expressions.Generic_Caches;

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

package body Natools.S_Expressions.Generic_Caches is

   --------------------
   -- Tree Interface --
   --------------------

   procedure Append
     (Exp : in out Tree;
      Kind : in Node_Kind;
      Data : in Atom_Access := null)
   is
      N : Node_Access;
   begin
      case Kind is
         when Atom_Node =>
            N := new Node'(Kind => Atom_Node,
              Parent | Next => null, Data => Data);
         when List_Node =>
            N := new Node'(Kind => List_Node, Parent | Next | Child => null);
      end case;

      if Exp.Root = null then
         pragma Assert (Exp.Last = null);
         Exp.Root := N;
      else
         pragma Assert (Exp.Last /= null);

         if Exp.Opening then
            pragma Assert (Exp.Last.Kind = List_Node);
            pragma Assert (Exp.Last.Child = null);
            Exp.Last.Child := N;
            N.Parent := Exp.Last;
         else
            pragma Assert (Exp.Last.Next = null);
            Exp.Last.Next := N;
            N.Parent := Exp.Last.Parent;
         end if;
      end if;

      Exp.Last := N;
      Exp.Opening := Kind = List_Node;
   end Append;

   procedure Close_List (Exp : in out Tree) is
   begin
      if Exp.Opening then
         Exp.Opening := False;
      elsif Exp.Last /= null and then Exp.Last.Parent /= null then
         Exp.Last := Exp.Last.Parent;
      end if;
   end Close_List;

   function Create_Tree return Tree is
   begin
      return Tree'(Ada.Finalization.Limited_Controlled
        with Root | Last => null, Opening => False);
   end Create_Tree;

   function Duplicate (Source : Tree) return Tree is
      function Dup_List (First, Parent : Node_Access) return Node_Access;
      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access;

      New_Last : Node_Access := null;

      function Dup_List (First, Parent : Node_Access) return Node_Access is
         Source : Node_Access := First;
         Result, Target : Node_Access;
      begin
         if First = null then
            return null;
         end if;
         Result := Dup_Node (First, Parent);
         Target := Result;
         loop
            Source := Source.Next;
            exit when Source = null;
            Target.Next := Dup_Node (Source, Parent);
            Target := Target.Next;
         end loop;
         return Result;
      end Dup_List;

      function Dup_Node (N : not null Node_Access; Parent : Node_Access)
        return Node_Access
      is
         Result : Node_Access;
      begin
         case N.Kind is
            when Atom_Node =>
               Result := new Node'(Kind => Atom_Node,
                 Parent => Parent,
                 Next => null,
                 Data => new Atom'(N.Data.all));
            when List_Node =>
               Result := new Node'(Kind => List_Node,
                 Parent => Parent,
                 Next => null,
                 Child => null);
               Result.Child := Dup_List (N.Child, Result);
         end case;

         if N = Source.Last then
            New_Last := Result;
         end if;

         return Result;
      end Dup_Node;
   begin
      return Result : Tree do
         Result.Root := Dup_List (Source.Root, null);
         pragma Assert ((New_Last = null) = (Source.Last = null));
         Result.Last := New_Last;
         Result.Opening := Source.Opening;
      end return;
   end Duplicate;

   overriding procedure Finalize (Object : in out Tree) is
      procedure List_Free (First : in out Node_Access);

      procedure List_Free (First : in out Node_Access) is
         Next : Node_Access := First;
         Cur : Node_Access;
      begin
         while Next /= null loop
            Cur := Next;

            case Cur.Kind is
               when Atom_Node =>
                  Unchecked_Free (Cur.Data);
               when List_Node =>
                  List_Free (Cur.Child);
            end case;

            Next := Cur.Next;
            Unchecked_Free (Cur);
         end loop;

         First := null;
      end List_Free;
   begin
      List_Free (Object.Root);
      Object.Last := null;
      Object.Opening := False;
   end Finalize;

   -----------------------
   -- Writing Interface --
   -----------------------

   function Duplicate (Cache : Reference) return Reference is
      function Dup_Tree return Tree;

      function Dup_Tree return Tree is
      begin
         return Duplicate (Cache.Exp.Query.Data.all);
      end Dup_Tree;
   begin
      return Reference'(Exp => Trees.Create (Dup_Tree'Access));
   end Duplicate;

   -----------------------
   -- Printer Interface --
   -----------------------

   overriding procedure Open_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Append (List_Node);
   end Open_List;

   overriding procedure Append_Atom
     (Output : in out Reference; Data : in Atom) is
   begin
      if Output.Exp.Is_Empty then
         Output.Exp.Replace (Create_Tree'Access);
      end if;

      Output.Exp.Update.Data.Append (Atom_Node, new Atom'(Data));
   end Append_Atom;

   overriding procedure Close_List (Output : in out Reference) is
   begin
      Output.Exp.Update.Data.Close_List;
   end Close_List;

   -------------------------
   -- Reading Subprograms --
   -------------------------

   function First (Cache : Reference'Class) return Cursor is
      N : Node_Access;
   begin
      if Cache.Exp.Is_Empty then
         return Cursor'(others => <>);
      else
         N := Cache.Exp.Query.Data.Root;
         pragma Assert (N /= null);
         return Cursor'(Exp => Cache.Exp, Position => N,
           Opening => N.Kind = List_Node);
      end if;
   end First;

   --------------------------
   -- Descriptor Interface --
   --------------------------

   overriding function Current_Event (Object : in Cursor)
     return Events.Event is
   begin
      if Object.Position = null then
         return Events.End_Of_Input;
      end if;

      case Object.Position.Kind is
         when Atom_Node =>
            return Events.Add_Atom;
         when List_Node =>
            if Object.Opening then
               return Events.Open_List;
            else
               return Events.Close_List;
            end if;
      end case;
   end Current_Event;

   overriding function Current_Atom (Object : in Cursor) return Atom is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      return Object.Position.Data.all;
   end Current_Atom;

   overriding function Current_Level (Object : in Cursor) return Natural is
      Result : Natural := 0;
      N : Node_Access := Object.Position;
   begin
      if Object.Position /= null
        and then Object.Position.Kind = List_Node
        and then Object.Opening
      then
         Result := Result + 1;
      end if;

      while N /= null loop
         Result := Result + 1;
         N := N.Parent;
      end loop;

      return Natural'Max (Result, 1) - 1;
   end Current_Level;

   overriding procedure Query_Atom
     (Object : in Cursor;
      Process : not null access procedure (Data : in Atom)) is
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Process.all (Object.Position.Data.all);
   end Query_Atom;

   overriding procedure Read_Atom
     (Object : in Cursor;
      Data : out Atom;
      Length : out Count)
   is
      Transferred : Count;
   begin
      if Object.Position = null or else Object.Position.Kind /= Atom_Node then
         raise Program_Error;
      end if;

      Length := Object.Position.Data'Length;
      Transferred := Count'Min (Data'Length, Length);
      Data (Data'First .. Data'First + Transferred - 1)
        := Object.Position.Data (Object.Position.Data'First
             .. Object.Position.Data'First + Transferred - 1);
   end Read_Atom;

   overriding procedure Next
     (Object : in out Cursor;
      Event : out Events.Event) is
   begin
      if Object.Position = null then
         Event := Events.End_Of_Input;
         return;
      end if;

      if Object.Opening then
         pragma Assert (Object.Position.Kind = List_Node);
         if Object.Position.Child = null then
            Object.Opening := False;
         else
            pragma Assert (Object.Position.Child.Parent = Object.Position);
            Object.Position := Object.Position.Child;
            Object.Opening := Object.Position.Kind = List_Node;
         end if;
      elsif Object.Position.Next /= null then
         pragma Assert (Object.Position.Next.Parent = Object.Position.Parent);
         Object.Position := Object.Position.Next;
         Object.Opening := Object.Position.Kind = List_Node;
      elsif Object.Position.Parent /= null then
         pragma Assert (Object.Position.Parent.Kind = List_Node);
         Object.Position := Object.Position.Parent;
         Object.Opening := False;
      else
         Object.Position := null;
      end if;

      Event := Object.Current_Event;
   end Next;

end Natools.S_Expressions.Generic_Caches;

s_expressions-generic_caches: return End_Of_Input instead of Error, to fix behaviour of empty cursors


-----------------------------------------------------------------------
--  mat-consoles-text - Text console interface
--  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 MAT.Interrupts;
with MAT.Commands;
package body MAT.Consoles.Text is

   --  ------------------------------
   --  Report an error message.
   --  ------------------------------
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Error;

   --  ------------------------------
   --  Report a notice message.
   --  ------------------------------
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is
      pragma Unreferenced (Console, Kind);
   begin
      Ada.Text_IO.Put_Line (Message);
   end Notice;

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is
      use type Ada.Text_IO.Count;

      Pos   : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
      Size  : constant Natural := Console.Sizes (Field);
      Start : Natural := Value'First;
      Last  : constant Natural := Value'Last;
      Pad   : Natural := 0;
   begin
      case Justify is
         when J_LEFT =>
            if Value'Length > Size then
               Start := Last - Size + 1;
            end if;

         when J_RIGHT =>
            if Value'Length < Size then
               Pad := Size - Value'Length - 1;
            else
               Start := Last - Size + 1;
            end if;

         when J_CENTER =>
            if Value'Length < Size then
               Pad  := (Size - Value'Length) / 2;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT_NO_FILL =>
            if Value'Length >= Size then
               Start := Last - Size + 1;
            end if;

      end case;
      if Pad > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad));
      elsif Pos > 1 then
         Ada.Text_IO.Set_Col (Pos);
      end if;
      Ada.Text_IO.Put (Value (Start .. Last));
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
      use type Ada.Text_IO.Count;

      Pos : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
   begin
      if Pos > 1 then
         Ada.Text_IO.Set_Col (Pos);
      end if;
      Ada.Text_IO.Put (Title);
   end Print_Title;

   --  ------------------------------
   --  Start a new title in a report.
   --  ------------------------------
   overriding
   procedure Start_Title (Console : in out Console_Type) is
   begin
      Console.Field_Count := 0;
      Console.Sizes := (others => 0);
      Console.Cols := (others => 1);
   end Start_Title;

   --  ------------------------------
   --  Finish a new title in a report.
   --  ------------------------------
   procedure End_Title (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      if MAT.Interrupts.Is_Interrupted then
         raise MAT.Commands.Stop_Command;
      end if;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      Ada.Text_IO.New_Line;
   end End_Row;

end MAT.Consoles.Text;

-----------------------------------------------------------------------
--  mat-consoles-text - Text console interface
--  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 ANSI;
with MAT.Interrupts;
with MAT.Commands;
package body MAT.Consoles.Text is

   --  ------------------------------
   --  Report an error message.
   --  ------------------------------
   overriding
   procedure Error (Console : in out Console_Type;
                    Message : in String) is
   begin
      Ada.Text_IO.Put (ANSI.Foreground (ANSI.Red));
      Ada.Text_IO.Put (Message);
      Ada.Text_IO.Put (ANSI.Reset);
      Ada.Text_IO.New_Line;
      Console.Cur_Col := 0;
   end Error;

   --  ------------------------------
   --  Report a notice message.
   --  ------------------------------
   overriding
   procedure Notice (Console : in out Console_Type;
                     Kind    : in Notice_Type;
                     Message : in String) is
      pragma Unreferenced (Kind);
   begin
      Ada.Text_IO.Put (ANSI.Foreground (ANSI.Blue));
      Ada.Text_IO.Put (Message);
      Ada.Text_IO.Put (ANSI.Reset);
      Ada.Text_IO.New_Line;
      Console.Cur_Col := 0;
   end Notice;

   --  ------------------------------
   --  Print the field value for the given field.
   --  ------------------------------
   overriding
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in String;
                          Justify : in Justify_Type := J_LEFT) is
      use type Ada.Text_IO.Count;

      Pos   : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
      Size  : constant Natural := Console.Sizes (Field);
      Start : Natural := Value'First;
      Last  : constant Natural := Value'Last;
      Pad   : Natural := 0;
   begin
      case Justify is
         when J_LEFT =>
            if Value'Length > Size then
               Start := Last - Size + 1;
            end if;

         when J_RIGHT =>
            if Value'Length < Size then
               Pad := Size - Value'Length - 1;
            else
               Start := Last - Size + 1;
            end if;

         when J_CENTER =>
            if Value'Length < Size then
               Pad  := (Size - Value'Length) / 2;
            else
               Start := Last - Size + 1;
            end if;

         when J_RIGHT_NO_FILL =>
            if Value'Length >= Size then
               Start := Last - Size + 1;
            end if;

      end case;
      if Pad > 0 then
         Ada.Text_IO.Set_Col (Pos + Ada.Text_IO.Count (Pad));
      elsif Pos > 1 then
         Ada.Text_IO.Set_Col (Pos);
      end if;
      Ada.Text_IO.Put (Value (Start .. Last));
      Console.Cur_Col := Console.Cur_Col + Ada.Text_IO.Count (Last - Start + 1);
   end Print_Field;

   --  ------------------------------
   --  Print the title for the given field.
   --  ------------------------------
   overriding
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String) is
      use type Ada.Text_IO.Count;

      Pos : constant Ada.Text_IO.Count := Ada.Text_IO.Count (Console.Cols (Field));
   begin
      if Pos > 1 then
         while Console.Cur_Col < Pos loop
            Ada.Text_IO.Put (' ');
            Console.Cur_Col := Console.Cur_Col + 1;
         end loop;
      end if;
      Ada.Text_IO.Put (Title);
      Console.Cur_Col := Console.Cur_Col + Title'Length;
   end Print_Title;

   --  ------------------------------
   --  Start a new title in a report.
   --  ------------------------------
   overriding
   procedure Start_Title (Console : in out Console_Type) is
   begin
      Console.Field_Count := 0;
      Console.Sizes := (others => 0);
      Console.Cols := (others => 1);
      Ada.Text_IO.Put (Ansi.Style (Ansi.Bright, Ansi.On));
      Ada.Text_IO.Put (ANSI.Foreground (ANSI.Light_Cyan));
      Console.Cur_Col := 0;
   end Start_Title;

   --  ------------------------------
   --  Finish a new title in a report.
   --  ------------------------------
   procedure End_Title (Console : in out Console_Type) is
   begin
      Ada.Text_Io.Put (ANSI.Reset);
      Ada.Text_IO.New_Line;
      Console.Cur_Col := 0;
   end End_Title;

   --  ------------------------------
   --  Start a new row in a report.
   --  ------------------------------
   overriding
   procedure Start_Row (Console : in out Console_Type) is
      pragma Unreferenced (Console);
   begin
      if MAT.Interrupts.Is_Interrupted then
         raise MAT.Commands.Stop_Command;
      end if;
   end Start_Row;

   --  ------------------------------
   --  Finish a new row in a report.
   --  ------------------------------
   overriding
   procedure End_Row (Console : in out Console_Type) is
   begin
      Ada.Text_IO.New_Line;
      Console.Cur_Col := 0;
   end End_Row;

end MAT.Consoles.Text;

Add support to use ANSI colors

Add support to use ANSI colors


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

   package ASC renames AWA.Services.Contexts;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Comment_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Comments.Models.Comment_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Comment_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "comment" then
         From.Set_Message (Util.Beans.Objects.To_String (Value));

      elsif Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "status" then
         From.Set_Status (AWA.Comments.Models.Status_Type_Objects.To_Value (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Module.Load_Comment (From, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the comment.
   --  ------------------------------
   overriding
   procedure Create (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Create_Comment (Permission  => Ada.Strings.Unbounded.To_String (Bean.Permission),
                                  Entity_Type => Ada.Strings.Unbounded.To_String (Bean.Entity_Type),
                                  Comment     => Bean);
   end Create;

   --  Save the comment.
   overriding
   procedure Save (Bean    : in out Comment_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Save;

   --  ------------------------------
   --  Delete the comment.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete_Comment (Ada.Strings.Unbounded.To_String (Bean.Permission), Bean);
   end Delete;

   --  ------------------------------
   --  Create a new comment bean instance.
   --  ------------------------------
   function Create_Comment_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                 return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_Bean_Access := new Comment_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_Bean;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_id" then
         From.Load_Comments (ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Set the entity type (database table) with which the comments are associated.
   --  ------------------------------
   procedure Set_Entity_Type (Into  : in out Comment_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access) is
   begin
      Into.Entity_Type := Ada.Strings.Unbounded.To_Unbounded_String (Table.Table.all);
   end Set_Entity_Type;

   --  ------------------------------
   --  Set the permission to check before removing or adding a comment on the entity.
   --  ------------------------------
   procedure Set_Permission (Into       : in out Comment_List_Bean;
                             Permission : in String) is
   begin
      Into.Permission := Ada.Strings.Unbounded.To_Unbounded_String (Permission);
   end Set_Permission;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            For_Entity_Id : in ADO.Identifier) is
      Session : ADO.Sessions.Session := Into.Module.Get_Session;
   begin
      Into.Load_Comments (Session, For_Entity_Id);
   end Load_Comments;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            Session       : in out ADO.Sessions.Session;
                            For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Into.Entity_Id := For_Entity_Id;
      Query.Set_Query (AWA.Comments.Models.Query_Comment_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      Query.Bind_Param ("status", Integer (Models.Status_Type'Pos (Models.COMMENT_PUBLISHED)));
      AWA.Comments.Models.List (Into, Session, Query);
   end Load_Comments;

   --  ------------------------------
   --  Create the comment list bean instance.
   --  ------------------------------
   function Create_Comment_List_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_List_Bean_Access := new Comment_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_List_Bean;

end AWA.Comments.Beans;

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

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the value identified by the name.
   --  ------------------------------
   overriding
   function Get_Value (From : in Comment_Bean;
                       Name : in String) return Util.Beans.Objects.Object is
   begin
      if From.Is_Null then
         return Util.Beans.Objects.Null_Object;
      else
         return AWA.Comments.Models.Comment_Bean (From).Get_Value (Name);
      end if;
   end Get_Value;

   --  ------------------------------
   --  Set the value identified by the name.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "message" then
         From.Set_Message (Util.Beans.Objects.To_String (Value));

      elsif Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "entity_id" then
         declare
            use type ADO.Identifier;

            Id : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            if Id /= ADO.NO_IDENTIFIER then
               From.Set_Entity_Id (ADO.Utils.To_Identifier (Value));
            end if;
         end;

      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);

      elsif Name = "status" then
         From.Set_Status (AWA.Comments.Models.Status_Type_Objects.To_Value (Value));

      elsif Name = "id" and not Util.Beans.Objects.Is_Empty (Value) then
         declare
            Id  : constant ADO.Identifier := ADO.Utils.To_Identifier (Value);
         begin
            From.Module.Load_Comment (From, Id);
         end;
      end if;
   end Set_Value;

   --  ------------------------------
   --  Create the comment.
   --  ------------------------------
   overriding
   procedure Create (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Create_Comment (Permission  => Ada.Strings.Unbounded.To_String (Bean.Permission),
                                  Entity_Type => Ada.Strings.Unbounded.To_String (Bean.Entity_Type),
                                  Comment     => Bean);
   end Create;

   --  Save the comment.
   overriding
   procedure Save (Bean    : in out Comment_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
   begin
      null;
   end Save;

   --  ------------------------------
   --  Delete the comment.
   --  ------------------------------
   overriding
   procedure Delete (Bean    : in out Comment_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String) is
      pragma Unreferenced (Outcome);
   begin
      Bean.Module.Delete_Comment (Ada.Strings.Unbounded.To_String (Bean.Permission), Bean);
   end Delete;

   --  ------------------------------
   --  Create a new comment bean instance.
   --  ------------------------------
   function Create_Comment_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                 return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_Bean_Access := new Comment_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_Bean;

   --  ------------------------------
   --  Set the value identified by the name.
   --  If the name cannot be found, the method should raise the No_Value
   --  exception.
   --  ------------------------------
   overriding
   procedure Set_Value (From  : in out Comment_List_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object) is
   begin
      if Name = "entity_type" then
         From.Entity_Type := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "permission" then
         From.Permission := Util.Beans.Objects.To_Unbounded_String (Value);
      elsif Name = "entity_id" then
         From.Load_Comments (ADO.Utils.To_Identifier (Value));
      end if;
   end Set_Value;

   --  ------------------------------
   --  Set the entity type (database table) with which the comments are associated.
   --  ------------------------------
   procedure Set_Entity_Type (Into  : in out Comment_List_Bean;
                              Table : in ADO.Schemas.Class_Mapping_Access) is
   begin
      Into.Entity_Type := Ada.Strings.Unbounded.To_Unbounded_String (Table.Table.all);
   end Set_Entity_Type;

   --  ------------------------------
   --  Set the permission to check before removing or adding a comment on the entity.
   --  ------------------------------
   procedure Set_Permission (Into       : in out Comment_List_Bean;
                             Permission : in String) is
   begin
      Into.Permission := Ada.Strings.Unbounded.To_Unbounded_String (Permission);
   end Set_Permission;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            For_Entity_Id : in ADO.Identifier) is
      Session : ADO.Sessions.Session := Into.Module.Get_Session;
   begin
      Into.Load_Comments (Session, For_Entity_Id);
   end Load_Comments;

   --  ------------------------------
   --  Load the comments associated with the given database identifier.
   --  ------------------------------
   procedure Load_Comments (Into          : in out Comment_List_Bean;
                            Session       : in out ADO.Sessions.Session;
                            For_Entity_Id : in ADO.Identifier) is
      use ADO.Sessions.Entities;

      Entity_Type : constant String := Ada.Strings.Unbounded.To_String (Into.Entity_Type);
      Kind        : constant ADO.Entity_Type := Find_Entity_Type (Session, Entity_Type);
      Query       : ADO.Queries.Context;
   begin
      Into.Entity_Id := For_Entity_Id;
      Query.Set_Query (AWA.Comments.Models.Query_Comment_List);
      Query.Bind_Param ("entity_type", Kind);
      Query.Bind_Param ("entity_id", For_Entity_Id);
      Query.Bind_Param ("status", Integer (Models.Status_Type'Pos (Models.COMMENT_PUBLISHED)));
      AWA.Comments.Models.List (Into, Session, Query);
   end Load_Comments;

   --  ------------------------------
   --  Create the comment list bean instance.
   --  ------------------------------
   function Create_Comment_List_Bean (Module : in AWA.Comments.Modules.Comment_Module_Access)
                                      return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Comment_List_Bean_Access := new Comment_List_Bean;
   begin
      Result.Module := Module;
      return Result.all'Access;
   end Create_Comment_List_Bean;

end AWA.Comments.Beans;

Fix the comment bean implementation

Fix the comment bean implementation


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

--  == Introduction ==
--  The <tt>Security</tt> package provides security frameworks that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;
--
--     --  Returns true if the given role is stored in the user principal.
--     function Has_Role (User : in Principal;
--                        Role : in Role_Type) return Boolean is abstract;

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

end Security;

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

--  == Introduction ==
--  The <tt>Security</tt> package provides security frameworks that allows
--  an application to use OpenID or OAuth security frameworks.  This security
--  framework was first developed within the Ada Server Faces project.
--  This package defines abstractions that are close or similar to Java
--  security package.
--
--  @include security-permissions.ads
--  @include security-openid.ads
--  @include security-oauth.ads
--  @include security-contexts.ads
--  @include security-controllers.ads
package Security is

   --  ------------------------------
   --  Principal
   --  ------------------------------
   type Principal is limited interface;
   type Principal_Access is access all Principal'Class;

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

end Security;

Make the Principal be a real principal (ie, no knowledge of roles)


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

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;
with Util.Beans.Methods;

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Ref
     and Util.Beans.Basic.Bean and Util.Beans.Methods.Method_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Blog_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access;

   --  Create a new blog.
   procedure Create_Blog (Bean    : in out Blog_Bean;
                          Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Post_Bean is new Util.Beans.Basic.Bean
     and Util.Beans.Methods.Method_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Post    : AWA.Blogs.Models.Post_Ref;
      Blog_Id : ADO.Identifier;
      Title   : Ada.Strings.Unbounded.Unbounded_String;
      Text    : Ada.Strings.Unbounded.Unbounded_String;
      URI     : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  This bean provides some methods that can be used in a Method_Expression
   overriding
   function Get_Method_Bindings (From : in Post_Bean)
                                 return Util.Beans.Methods.Method_Binding_Array_Access;

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create a new post.
   procedure Create_Post (Bean    : in out Post_Bean;
                          Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   procedure Delete_Post (Bean    : in out Post_Bean;
                          Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Admin_Post_List_Bean bean instance.
   function Create_Admin_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Blog_List_Bean bean instance.
   function Create_Blog_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Blogs.Beans;

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

with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Beans.Objects;

with ADO;

with AWA.Blogs.Modules;
with AWA.Blogs.Models;
package AWA.Blogs.Beans is

   --  Attributes exposed by Post_Bean
   BLOG_ID_ATTR      : constant String := "blogId";
   POST_ID_ATTR      : constant String := "id";
   POST_TITLE_ATTR   : constant String := "title";
   POST_TEXT_ATTR    : constant String := "text";
   POST_URI_ATTR     : constant String := "uri";
   POST_STATUS_ATTR  : constant String := "status";
   POST_USERNAME_ATTR : constant String := "username";

   --  ------------------------------
   --  Blog Bean
   --  ------------------------------
   --  The Blog_Bean holds the information about the current blog.
   --  It allows to create the blog as well as update its primary title.
   type Blog_Bean is new AWA.Blogs.Models.Blog_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
   end record;
   type Blog_Bean_Access is access all Blog_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Blog_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Blog_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Create a new blog.
   overriding
   procedure Create (Bean    : in out Blog_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   type Post_Bean is new AWA.Blogs.Models.Post_Bean with record
      Module  : AWA.Blogs.Modules.Blog_Module_Access := null;
      Blog_Id : ADO.Identifier;
   end record;
   type Post_Bean_Access is access all Post_Bean'Class;

   --  Get the value identified by the name.
   overriding
   function Get_Value (From : in Post_Bean;
                       Name : in String) return Util.Beans.Objects.Object;

   --  Set the value identified by the name.
   overriding
   procedure Set_Value (From  : in out Post_Bean;
                        Name  : in String;
                        Value : in Util.Beans.Objects.Object);

   --  Load the post.
   procedure Load_Post (Post : in out Post_Bean;
                        Id   : in ADO.Identifier);

   --  Create or save the post.
   overriding
   procedure Save (Bean    : in out Post_Bean;
                   Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Delete a post.
   overriding
   procedure Delete (Bean    : in out Post_Bean;
                     Outcome : in out Ada.Strings.Unbounded.Unbounded_String);

   --  Create the Blog_Bean bean instance.
   function Create_Blog_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_Bean bean instance.
   function Create_Post_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                              return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Post_List_Bean bean instance.
   function Create_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Admin_Post_List_Bean bean instance.
   function Create_Admin_Post_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Create the Blog_List_Bean bean instance.
   function Create_Blog_List_Bean (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                   return Util.Beans.Basic.Readonly_Bean_Access;

   --  Get a select item list which contains a list of post status.
   function Create_Status_List (Module : in AWA.Blogs.Modules.Blog_Module_Access)
                                return Util.Beans.Basic.Readonly_Bean_Access;

end AWA.Blogs.Beans;

Use the UML generated Ada bean - implement the Save and Delete operations defined by the UML model - simplify the implementation


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

with AWA.Users.Models;
with AWA.Users.Principals;
with AWA.Permissions.Services;
with AWA.Modules;
with AWA.Modules.Lifecycles;
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");

   package User_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Users.Models.User_Ref'Class);

   subtype Listener is User_Lifecycle.Listener;

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

   --  Create a user in the database with the given user information and
   --  the associated email address and for the given access key.  The access key is first
   --  verified and the user instance associated with it is retrieved.  Verify that the email
   --  address is unique and can be used by the user.  Since the access key is verified,
   --  grant immediately the access by opening a session and setting up the principal instance.
   --  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;
                          Key       : in String;
                          IpAddr    : in String;
                          Principal : out AWA.Users.Principals.Principal_Access);

   --  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;
                                Kind    : in AWA.Users.Models.Key_Type;
                                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;
      Permissions : AWA.Permissions.Services.Permission_Manager_Access;
   end record;

end AWA.Users.Services;

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

with AWA.Users.Models;
with AWA.Users.Principals;
with AWA.Permissions.Services;
with AWA.Modules;
with AWA.Modules.Lifecycles;
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");

   package User_Lifecycle is
     new AWA.Modules.Lifecycles (Element_Type => AWA.Users.Models.User_Ref'Class);

   subtype Listener is User_Lifecycle.Listener;

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

   --  Create a user in the database with the given user information and
   --  the associated email address and for the given access key.  The access key is first
   --  verified and the user instance associated with it is retrieved.  Verify that the email
   --  address is unique and can be used by the user.  Since the access key is verified,
   --  grant immediately the access by opening a session and setting up the principal instance.
   --  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;
                          Key       : in String;
                          IpAddr    : in String;
                          Principal : out AWA.Users.Principals.Principal_Access);

   --  Load the user and email address from the invitation key.
   procedure Load_User (Model     : in out User_Service;
                        User      : in out User_Ref'Class;
                        Email     : in out Email_Ref'Class;
                        Key       : in String);

   --  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;
                                Kind    : in AWA.Users.Models.Key_Type;
                                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;
      Permissions : AWA.Permissions.Services.Permission_Manager_Access;
   end record;

end AWA.Users.Services;

Declare the Load_User procedure

Declare the Load_User procedure