with Ada.Text_IO;
with Ada.Command_Line;

procedure Symbolica is

   NumColors  : constant := 4;
   NumSymbols : constant := 3;
   Length     : constant := 5;
   Width      : constant := 5;

   package IO renames Ada.Text_IO;

   type Color_T  is new Natural range 0 .. NumColors - 1;
   type Symbol_T is new Natural range 0 .. NumSymbols - 1;
   type Column_T is new Natural range 1 .. Length;
   type Row_T    is new Natural range 1 .. Width;

   type Tile_T is record
      Color : Color_T;
      Symbol : Symbol_T;
   end record;

   type Board_T is Array(Row_T, Column_T) of Tile_T;
   type Count_T is Array(Color_T, Symbol_T) of Natural;

   colors  : constant Array(Color_T) of Character := ('R', 'B', 'G', 'Y');
   symbols : constant Array(Symbol_T) of Character := ('a', 'g', 'c');

   original_board, best_board, board : Board_T;

   best_distance   : Natural := Length * Width;
   total_solutions : Natural := 0;
   iterations      : Natural := 0;
   tile_count      : Count_T := (others => (others => 0));

   Not_In : exception;

   function GetColor(c: Character) return Color_T is
   begin
      for color in Color_T'Range loop
         if colors(color) = c then
            return color;
         end if;
      end loop;
      raise Not_In;
   end GetColor;

   function GetSymbol(s: Character) return Symbol_T is
   begin
      for symbol in Symbol_T'Range loop
         if symbols(symbol) = s then
            return symbol;
         end if;
      end loop;
      raise Not_In;
   end GetSymbol;

   function TileImage(tile : Tile_T) return String is
   begin
      return (colors(tile.Color), symbols(tile.Symbol));
   end TileImage;
   procedure PrintBoard(b : Board_T) is
   begin
      for r in Row_T loop
         for c in Column_T loop
            IO.Put(TileImage(b(r,c)) & " ");
         end loop;
         IO.New_Line;
      end loop;
   end PrintBoard;

   procedure ReadBoard(filename: in String; b : out Board_T) is
      f : IO.File_Type;
      c,s : Character;
      eol : Boolean;
   begin
      IO.Open(f, IO.In_File, filename);
      for row in Row_T'Range loop
         for col in Column_T'Range loop
            IO.Get(f, c);
            IO.Get(f, s);
            b(row, col) := (GetColor(c), GetSymbol(s));
            loop
               IO.Look_Ahead(f,c,eol);
               exit when eol or else c /= ' ';
               IO.Get(f, c);
            end loop;
         end loop;
      end loop;
      IO.Put_Line("Read in original Board");
      PrintBoard(b);
   end ReadBoard;

   procedure CompareBoards is
      distance : Natural := 0;
      chain : Natural := 0;
      waiting : Array(Color_T, Symbol_T, Color_T, Symbol_T) of Natural := (others => (others => (others => (others => 0))));
   begin
      total_solutions := total_solutions + 1;
      for row in Row_T'Range loop
         for col in Column_T'Range loop
            declare
               o : Tile_T renames original_board(row, col);
               b : Tile_T renames board(row, col);
               w : natural renames waiting(o.Color, o.Symbol, b.Color, b.Symbol);
               ow : natural renames waiting(b.Color, b.Symbol, o.Color, o.Symbol);
            begin
               if o.Color /= b.Color or else o.Symbol /= b.Symbol then
                  if ow > 0 then
                     ow := ow - 1;
                     chain := chain - 1;
                     distance := distance + 1;
                  else
                     chain := chain + 1;
                     w := w + 1;
                  end if;
               end if;
            end;
         end loop;
      end loop;
      if chain > 0 then
         distance := distance + chain - 1;
      end if;
      if distance < best_distance then
         best_board := board;
         best_distance := distance;
      end if;
   end CompareBoards;

   procedure Solve(row : Row_T; col : Column_T) is

      procedure NextSolve(c : Color_T; s : Symbol_T) is
         tc : Natural renames tile_count(c, s);
      begin
         if tc = 0 then
            return;
         end if;
         board(row, col) := (c, s);
         if col = Column_T'Last then
            if row = Row_T'Last then
               CompareBoards;
            else
               tc := tc - 1;
               Solve(row + 1, 1);
               tc := tc + 1;
            end if;
         else
            tc := tc - 1;
            Solve(row, col + 1);
            tc := tc + 1;
         end if;
      end NextSolve;
      pragma inline(NextSolve);

   begin
      iterations := iterations + 1;
      if row = 1 then
         declare
            left : Tile_T renames board(row, col - 1);
         begin
            for color in Color_T'Range loop
               if color /= left.Color then
                  NextSolve(color, left.Symbol);
               end if;
            end loop;
            for symbol in Symbol_T'Range loop
               if symbol /= left.Symbol then
                  NextSolve(left.Color, symbol);
               end if;
            end loop;
         end;
      elsif col = 1 then
         declare
            above : Tile_T renames board(row - 1, col);
         begin
            for color in Color_T'Range loop
               if color /= above.Color then
                  NextSolve(color, above.Symbol);
               end if;
            end loop;
            for symbol in Symbol_T'Range loop
               if symbol /= above.Symbol then
                  NextSolve(above.Color, symbol);
               end if;
            end loop;
         end;
      else
         declare
            left : Tile_T renames board(row, col -1);
            above : Tile_T renames board(row - 1, col);
         begin
            if left.Color = above.Color then
               for symbol in Symbol_T'Range loop
                  if symbol /= left.Symbol and then symbol /= above.Symbol then
                     NextSolve(left.Color, symbol);
                  end if;
               end loop;
            elsif left.Symbol = above.Symbol then
               for color in Color_T'Range loop
                  if color /= left.Color and then color /= above.Color then
                     NextSolve(color, left.Symbol);
                  end if;
               end loop;
            else
               NextSolve(left.Color, above.Symbol);
               NextSolve(above.Color, left.Symbol);
            end if;
         end;
      end if;
   end Solve;

begin
   ReadBoard(Ada.Command_Line.Argument(1), original_board);
   for row in Row_T'Range loop
      for col in Column_T'Range loop
         declare
            tile : constant Tile_T := original_board(row, col);
         begin
            tile_count(tile.Color, tile.Symbol) := tile_count(tile.Color, tile.Symbol) + 1;
         end;
      end loop;
   end loop;
   for color in Color_T'Range loop
      for symbol in Symbol_T'Range loop
         board(1, 1) := (color, symbol);
         Solve(1, 2);
      end loop;
   end loop;
   IO.Put_Line("Total Iterations" & Natural'Image(iterations));
   IO.Put_Line("Total Solutions found:" & Natural'Image(total_solutions));
   IO.Put_Line("Total Swaps: " & Natural'Image(best_distance));
   PrintBoard(best_board);
end Symbolica;

with Ada.Text_IO;
with Ada.Command_Line;

procedure Symbolica is

   NumColors  : constant := 4;
   NumSymbols : constant := 3;
   Length     : constant := 5;
   Width      : constant := 5;

   package IO renames Ada.Text_IO;

   type Color_T  is new Natural range 0 .. NumColors - 1;
   type Symbol_T is new Natural range 0 .. NumSymbols - 1;
   type Column_T is new Natural range 1 .. Length;
   type Row_T    is new Natural range 1 .. Width;

   type Tile_T is record
      Color  : Color_T;
      Symbol : Symbol_T;
   end record;

   type Board_T is Array(Row_T, Column_T)   of Tile_T;
   type Count_T is Array(Color_T, Symbol_T) of Natural;

   colors  : constant Array(Color_T)  of Character := ('R', 'B', 'G', 'Y');
   symbols : constant Array(Symbol_T) of Character := ('a', 'g', 'c');

   original_board, best_board, board : Board_T;

   best_distance   : Natural := Length * Width;
   total_solutions : Natural := 0;
   iterations      : Natural := 0;
   tile_count      : Count_T := (others => (others => 0));

   function TileImage(tile : Tile_T) return String is
   begin
      return (colors(tile.Color), symbols(tile.Symbol));
   end TileImage;
   procedure PrintBoard(b : Board_T) is
   begin
      for r in Row_T loop
         for c in Column_T loop
            IO.Put(TileImage(b(r,c)) & " ");
         end loop;
         IO.New_Line;
      end loop;
   end PrintBoard;

   procedure ReadBoard(filename: in String; b : out Board_T) is

      Not_In : exception;

      function GetColor(c: Character) return Color_T is
      begin
         for color in Color_T'Range loop
            if colors(color) = c then
               return color;
            end if;
         end loop;
         raise Not_In;
      end GetColor;

      function GetSymbol(s: Character) return Symbol_T is
      begin
         for symbol in Symbol_T'Range loop
            if symbols(symbol) = s then
               return symbol;
            end if;
         end loop;
         raise Not_In;
      end GetSymbol;

      f   : IO.File_Type;
      c,s : Character;
      eol : Boolean;
   begin
      IO.Open(f, IO.In_File, filename);
      for row in Row_T'Range loop
         for col in Column_T'Range loop
            IO.Get(f, c);
            IO.Get(f, s);
            b(row, col) := (GetColor(c), GetSymbol(s));
            loop
               IO.Look_Ahead(f,c,eol);
               exit when eol or else c /= ' ';
               IO.Get(f, c);
            end loop;
         end loop;
      end loop;
      IO.Put_Line("Read in original Board");
      PrintBoard(b);
   end ReadBoard;

   procedure CompareBoards is
      distance : Natural := 0;
      chain : Natural := 0;
      waiting : Array(Color_T, Symbol_T, Color_T, Symbol_T) of Natural := (others => (others => (others => (others => 0))));
   begin
      total_solutions := total_solutions + 1;
      for row in Row_T'Range loop
         for col in Column_T'Range loop
            declare
               o : Tile_T renames original_board(row, col);
               b : Tile_T renames board(row, col);
               w : natural renames waiting(o.Color, o.Symbol, b.Color, b.Symbol);
               ow : natural renames waiting(b.Color, b.Symbol, o.Color, o.Symbol);
            begin
               if o.Color /= b.Color or else o.Symbol /= b.Symbol then
                  if ow > 0 then
                     ow := ow - 1;
                     chain := chain - 1;
                     distance := distance + 1;
                  else
                     chain := chain + 1;
                     w := w + 1;
                  end if;
               end if;
            end;
         end loop;
      end loop;
      if chain > 0 then
         distance := distance + chain - 1;
      end if;
      if distance < best_distance then
         best_board := board;
         best_distance := distance;
      end if;
   end CompareBoards;

   procedure Solve(row : Row_T; col : Column_T) is

      procedure NextSolve(c : Color_T; s : Symbol_T) is
         tc : Natural renames tile_count(c, s);
      begin
         if tc = 0 then
            return;
         end if;
         board(row, col) := (c, s);
         if col = Column_T'Last then
            if row = Row_T'Last then
               CompareBoards;
            else
               tc := tc - 1;
               Solve(row + 1, 1);
               tc := tc + 1;
            end if;
         else
            tc := tc - 1;
            Solve(row, col + 1);
            tc := tc + 1;
         end if;
      end NextSolve;
      pragma inline(NextSolve);

   begin
      iterations := iterations + 1;
      if row = 1 then
         declare
            left : Tile_T renames board(row, col - 1);
         begin
            for color in Color_T'Range loop
               if color /= left.Color then
                  NextSolve(color, left.Symbol);
               end if;
            end loop;
            for symbol in Symbol_T'Range loop
               if symbol /= left.Symbol then
                  NextSolve(left.Color, symbol);
               end if;
            end loop;
         end;
      elsif col = 1 then
         declare
            above : Tile_T renames board(row - 1, col);
         begin
            for color in Color_T'Range loop
               if color /= above.Color then
                  NextSolve(color, above.Symbol);
               end if;
            end loop;
            for symbol in Symbol_T'Range loop
               if symbol /= above.Symbol then
                  NextSolve(above.Color, symbol);
               end if;
            end loop;
         end;
      else
         declare
            left  : Tile_T renames board(row, col -1);
            above : Tile_T renames board(row - 1, col);
         begin
            if left.Color = above.Color then
               for symbol in Symbol_T'Range loop
                  if symbol /= left.Symbol and then symbol /= above.Symbol then
                     NextSolve(left.Color, symbol);
                  end if;
               end loop;
            elsif left.Symbol = above.Symbol then
               for color in Color_T'Range loop
                  if color /= left.Color and then color /= above.Color then
                     NextSolve(color, left.Symbol);
                  end if;
               end loop;
            else
               NextSolve(left.Color, above.Symbol);
               NextSolve(above.Color, left.Symbol);
            end if;
         end;
      end if;
   end Solve;

begin
   ReadBoard(Ada.Command_Line.Argument(1), original_board);
   for row in Row_T'Range loop
      for col in Column_T'Range loop
         declare
            tile : constant Tile_T := original_board(row, col);
         begin
            tile_count(tile.Color, tile.Symbol) := tile_count(tile.Color, tile.Symbol) + 1;
         end;
      end loop;
   end loop;
   for color in Color_T'Range loop
      for symbol in Symbol_T'Range loop
         board(1, 1) := (color, symbol);
         Solve(1, 2);
      end loop;
   end loop;
   IO.Put_Line("Total Iterations" & Natural'Image(iterations));
   IO.Put_Line("Total Solutions found:" & Natural'Image(total_solutions));
   IO.Put_Line("Total Swaps: " & Natural'Image(best_distance));
   PrintBoard(best_board);
end Symbolica;

Move the functions dealing with turning characters into symbols inside the parsing function to clean up the cognitive load on them.


-----------------------------------------------------------------------
--  gen-utils -- Utilities for model generator
--  Copyright (C) 2010, 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 Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;
with Ada.Containers.Hashed_Sets;
with Ada.Containers.Indefinite_Vectors;

with DOM.Core;
package Gen.Utils is

   --  Generic procedure to iterate over the DOM nodes children of node
   --  and having the entity name name.
   generic
      type T is limited private;
      with procedure Process (Closure : in out T;
                              Node    : DOM.Core.Node);
   procedure Iterate_Nodes (Closure : in out T;
                            Node    : DOM.Core.Node;
                            Name    : String);

   --  Get the content of the node
   function Get_Data_Content (Node : in DOM.Core.Node) return String;

   --  Get the Ada package name from a qualified type
   function Get_Package_Name (Name : in String) return String;

   --  Get the Ada type name from a full qualified type
   function Get_Type_Name (Name : in String) return String;

   --  Get a query name from the XML query file name
   function Get_Query_Name (Path : in String) return String;

   use Ada.Strings.Unbounded;
   package String_Set is
     new Ada.Containers.Hashed_Sets (Element_Type    => Ada.Strings.Unbounded.Unbounded_String,
                                     Hash            => Ada.Strings.Unbounded.Hash,
                                     Equivalent_Elements => Ada.Strings.Unbounded."=");

   package String_List is new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                                                 Element_Type => String,
                                                                 "="          => "=");

   --  Returns True if the Name is a valid project or module name.
   --  The name must be a valid Ada identifier.
   function Is_Valid_Name (Name : in String) return Boolean;

end Gen.Utils;

-----------------------------------------------------------------------
--  gen-utils -- Utilities for model generator
--  Copyright (C) 2010, 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 Ada.Strings.Unbounded;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Indefinite_Vectors;

with DOM.Core;
package Gen.Utils is

   --  Generic procedure to iterate over the DOM nodes children of node
   --  and having the entity name name.
   generic
      type T is limited private;
      with procedure Process (Closure : in out T;
                              Node    : DOM.Core.Node);
   procedure Iterate_Nodes (Closure : in out T;
                            Node    : DOM.Core.Node;
                            Name    : String);

   --  Get the content of the node
   function Get_Data_Content (Node : in DOM.Core.Node) return String;

   --  Get the Ada package name from a qualified type
   function Get_Package_Name (Name : in String) return String;

   --  Get the Ada type name from a full qualified type
   function Get_Type_Name (Name : in String) return String;

   --  Get a query name from the XML query file name
   function Get_Query_Name (Path : in String) return String;

   use Ada.Strings.Unbounded;
   package String_Set is
     new Ada.Containers.Ordered_Sets (Element_Type => Ada.Strings.Unbounded.Unbounded_String,
                                      "<"          => Ada.Strings.Unbounded."<",
                                      "="          => Ada.Strings.Unbounded."=");

   package String_List is new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                                                 Element_Type => String,
                                                                 "="          => "=");

   --  Returns True if the Name is a valid project or module name.
   --  The name must be a valid Ada identifier.
   function Is_Valid_Name (Name : in String) return Boolean;

end Gen.Utils;

Change to an Ordered_Sets to ensure a coherent and reproducible code generation


-----------------------------------------------------------------------
--  ado-audits-tests -- Audit tests
--  Copyright (C) 2018, 2019 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.Test_Caller;
with Util.Strings;

with Ada.Text_IO;
with Regtests.Audits.Model;

with ADO.SQL;
with ADO.Sessions.Entities;
package body ADO.Audits.Tests is

   use type ADO.Objects.Object_Key_Type;

   package Caller is new Util.Test_Caller (Test, "ADO.Audits");

   type Test_Audit_Manager is new Audit_Manager with null record;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array);

   Audit_Instance : aliased Test_Audit_Manager;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array) is
      pragma Unreferenced (Manager);

      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : Regtests.Audits.Model.Audit_Ref;
         begin
            if Object.Key_Type = ADO.Objects.KEY_INTEGER then
              Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            end if;
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            Audit.Set_New_Value (UBO.To_String (C.New_Value));
            Audit.Set_Date (Now);
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Audits.Audit_Field",
                       Test_Audit_Field'Access);
   end Add_Tests;

   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      Regtests.Set_Audit_Manager (Audit_Instance'Access);
   end Set_Up;

   --  ------------------------------
   --  Test populating Audit_Fields
   --  ------------------------------
   procedure Test_Audit_Field (T : in out Test) is
      type Identifier_Array is array (1 .. 10) of ADO.Identifier;

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Email  : Regtests.Audits.Model.Email_Ref;
      List   : Identifier_Array;
   begin
      for I in List'Range loop
         Email := Regtests.Audits.Model.Null_Email;
         Email.Set_Email ("Email" & Util.Strings.Image (I) & "@nowhere.com");
         Email.Set_Status (ADO.Nullable_Integer '(23, False));
         Email.Save (DB);
         List (I) := Email.Get_Id;
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@here.com");
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@there.com");
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Null_Integer);
         Email.Save (DB);
      end loop;
      DB.Commit;

      declare
         Query : ADO.SQL.Query;
         Audit_List : Regtests.Audits.Model.Audit_Vector;
      begin
         Query.Set_Filter ("entity_id = :entity_id");
         for Id of List loop
            Query.Bind_Param ("entity_id", Id);
            Regtests.Audits.Model.List (Audit_List, DB, Query);
            for A of Audit_List loop
               Ada.Text_IO.Put_Line (ADO.Identifier'Image (Id) & " "
                                     & ADO.Identifier'Image (A.Get_Id)
                                     & " " & A.Get_Old_Value & " - "
                                     & A.Get_New_Value);

               Util.Tests.Assert_Equals (T, Natural (Id), Natural (A.Get_Entity_Id),
                                         "Invalid audit record: id is wrong");
            end loop;

            Util.Tests.Assert_Equals (T, 7, Natural (Audit_List.Length),
                                      "Invalid number of audit records");
         end loop;
      end;
   end Test_Audit_Field;

end ADO.Audits.Tests;

-----------------------------------------------------------------------
--  ado-audits-tests -- Audit tests
--  Copyright (C) 2018, 2019 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.Test_Caller;
with Util.Strings;

with Ada.Text_IO;
with Regtests.Audits.Model;

with ADO.SQL;
with ADO.Sessions.Entities;
package body ADO.Audits.Tests is

   use type ADO.Objects.Object_Key_Type;

   package Caller is new Util.Test_Caller (Test, "ADO.Audits");

   type Test_Audit_Manager is new Audit_Manager with null record;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array);

   Audit_Instance : aliased Test_Audit_Manager;

   --  Save the audit changes in the database.
   overriding
   procedure Save (Manager : in out Test_Audit_Manager;
                   Session : in out ADO.Sessions.Master_Session'Class;
                   Object  : in Auditable_Object_Record'Class;
                   Changes : in Audit_Array) is
      pragma Unreferenced (Manager);

      Now  : constant Ada.Calendar.Time := Ada.Calendar.Clock;
      Kind : constant ADO.Entity_Type
        := ADO.Sessions.Entities.Find_Entity_Type (Session, Object.Get_Key);
   begin
      for C of Changes loop
         declare
            Audit : Regtests.Audits.Model.Audit_Ref;
         begin
            if Object.Key_Type = ADO.Objects.KEY_INTEGER then
              Audit.Set_Entity_Id (ADO.Objects.Get_Value (Object.Get_Key));
            end if;
            Audit.Set_Entity_Type (Kind);
            Audit.Set_Old_Value (UBO.To_String (C.Old_Value));
            Audit.Set_New_Value (UBO.To_String (C.New_Value));
            Audit.Set_Date (Now);
            Audit.Save (Session);
         end;
      end loop;
   end Save;

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Audits.Audit_Field",
                       Test_Audit_Field'Access);
   end Add_Tests;

   procedure Set_Up (T : in out Test) is
      pragma Unreferenced (T);
   begin
      Regtests.Set_Audit_Manager (Audit_Instance'Access);
   end Set_Up;

   --  ------------------------------
   --  Test populating Audit_Fields
   --  ------------------------------
   procedure Test_Audit_Field (T : in out Test) is
      type Identifier_Array is array (1 .. 10) of ADO.Identifier;

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Email  : Regtests.Audits.Model.Email_Ref;
      Prop   : Regtests.Audits.Model.Property_Ref;
      List   : Identifier_Array;
   begin
      for I in List'Range loop
         Email := Regtests.Audits.Model.Null_Email;
         Email.Set_Email ("Email" & Util.Strings.Image (I) & "@nowhere.com");
         Email.Set_Status (ADO.Nullable_Integer '(23, False));
         Email.Save (DB);
         List (I) := Email.Get_Id;
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@here.com");
         Email.Save (DB);

         Email.Set_Email ("Email" & Util.Strings.Image (Email.Get_Status.Value) & "@there.com");
         Email.Set_Status (ADO.Nullable_Integer '(Email.Get_Status.Value + 1, False));
         Email.Save (DB);
      end loop;
      DB.Commit;

      for Id of List loop
         Email.Load (DB, Id);
         Email.Set_Status (ADO.Null_Integer);
         Email.Save (DB);
      end loop;
      DB.Commit;

      for I in 1 .. 10 loop
         Prop.Set_Value ((Value => I, Is_Null => False));
         Prop.Set_Float_Value (3.0 * Float (I));
         Prop.Save (DB);
      end loop;

      declare
         Query : ADO.SQL.Query;
         Audit_List : Regtests.Audits.Model.Audit_Vector;
      begin
         Query.Set_Filter ("entity_id = :entity_id");
         for Id of List loop
            Query.Bind_Param ("entity_id", Id);
            Regtests.Audits.Model.List (Audit_List, DB, Query);
            for A of Audit_List loop
               Ada.Text_IO.Put_Line (ADO.Identifier'Image (Id) & " "
                                     & ADO.Identifier'Image (A.Get_Id)
                                     & " " & A.Get_Old_Value & " - "
                                     & A.Get_New_Value);

               Util.Tests.Assert_Equals (T, Natural (Id), Natural (A.Get_Entity_Id),
                                         "Invalid audit record: id is wrong");
            end loop;

            Util.Tests.Assert_Equals (T, 7, Natural (Audit_List.Length),
                                      "Invalid number of audit records");
         end loop;
      end;
   end Test_Audit_Field;

end ADO.Audits.Tests;

Add test on Property_Def with float

Add test on Property_Def with float


-----------------------------------------------------------------------
--  awa-questions-services-tests -- Unit tests for storage service
--  Copyright (C) 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.Streams;
with Ada.Strings.Unbounded;

with Util.Test_Caller;

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Questions.Modules;
with AWA.Tests.Helpers.Users;
package body AWA.Questions.Services.Tests is

   use Util.Tests;
   use ADO;

   package Caller is new Util.Test_Caller (Test, "Questions.Services");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Storages.Services.Save (DATABASE)",
                       Test_Create_Question'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a question.
   --  ------------------------------
   procedure Test_Create_Question (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Q         : AWA.Questions.Models.Question_Ref;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Manager := AWA.Questions.Modules.Get_Question_Manager;
      T.Assert (T.Manager /= null, "There is no question manager");

      Q.Set_Title ("How can I append strings in Ada?");
      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work.");
      T.Manager.Save_Question (Q);
      T.Assert (Q.Is_Inserted, "The new question was not inserted");

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                        & "I also tried '.' without success.  What should I do?");
      T.Manager.Save_Question (Q);

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                         & "I also tried '.' without success.  What should I do? "
                         & "This is a stupid question for someone who reads this file. "
                         & "But I need some long text for the unit test.");
      T.Manager.Save_Question (Q);
   end Test_Create_Question;

end AWA.Questions.Services.Tests;

-----------------------------------------------------------------------
--  awa-questions-services-tests -- Unit tests for storage service
--  Copyright (C) 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.Streams;
with Ada.Strings.Unbounded;

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

with ADO;
with ADO.Objects;

with Security.Contexts;

with AWA.Services.Contexts;
with AWA.Questions.Modules;
with AWA.Questions.Beans;
with AWA.Tests.Helpers.Users;
package body AWA.Questions.Services.Tests is

   use Util.Tests;
   use ADO;

   package Caller is new Util.Test_Caller (Test, "Questions.Services");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Questions.Services.Save_Question",
                       Test_Create_Question'Access);
      Caller.Add_Test (Suite, "Test AWA.Questions.Queries question-list",
                       Test_List_Questions'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of a question.
   --  ------------------------------
   procedure Test_Create_Question (T : in out Test) is
      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Q         : AWA.Questions.Models.Question_Ref;
   begin
      AWA.Tests.Helpers.Users.Login (Context, Sec_Ctx, "test-storage@test.com");

      T.Manager := AWA.Questions.Modules.Get_Question_Manager;
      T.Assert (T.Manager /= null, "There is no question manager");

      Q.Set_Title ("How can I append strings in Ada?");
      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work.");
      T.Manager.Save_Question (Q);
      T.Assert (Q.Is_Inserted, "The new question was not inserted");

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                        & "I also tried '.' without success.  What should I do?");
      T.Manager.Save_Question (Q);

      Q.Set_Description ("I have two strings that I want to concatenate.  + does not work. "
                         & "I also tried '.' without success.  What should I do? "
                         & "This is a stupid question for someone who reads this file. "
                         & "But I need some long text for the unit test.");
      T.Manager.Save_Question (Q);
   end Test_Create_Question;

   --  ------------------------------
   --  Test list of questions.
   --  ------------------------------
   procedure Test_List_Questions (T : in out Test) is
      use AWA.Questions.Models;
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Sec_Ctx   : Security.Contexts.Security_Context;
      Context   : AWA.Services.Contexts.Service_Context;
      Q         : AWA.Questions.Models.Question_Ref;
      Module    : AWA.Questions.Modules.Question_Module_Access;
      List      : Util.Beans.Basic.Readonly_Bean_Access;
      Bean      : Util.Beans.Objects.Object;
      Count     : Natural;
   begin
      AWA.Tests.Helpers.Users.Anonymous (Context, Sec_Ctx);
      Module := AWA.Questions.Modules.Get_Question_Module;
      List := AWA.Questions.Beans.Create_Question_List_Bean (Module);
      T.Assert (List /= null, "The Create_Question_List_Bean returned null");

      Bean := Util.Beans.Objects.To_Object (List);
      T.Assert (not Util.Beans.Objects.Is_Null (Bean), "The list bean should not be null");
      Count := Questions.Models.Question_Info_List_Bean'Class (List.all).Get_Count;

      T.Assert (Count > 0, "The list of question is empty");
   end Test_List_Questions;

end AWA.Questions.Services.Tests;

Add new unit test to check list of questions from anonymous user


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

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

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

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

   --  Use the Google+ OpenID Connect Basic Client
   PROVIDER_GOOGLE_PLUS : constant String := "google-plus";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

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

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

   function To_String (OP : End_Point) return String;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

private

   use Ada.Strings.Unbounded;

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

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

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

   type Manager_Access is access all Manager'Class;

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

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

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

end Security.Auth;

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

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

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

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

   --  Use the Google+ OpenID Connect Basic Client
   PROVIDER_GOOGLE_PLUS : constant String := "google-plus";

   Invalid_End_Point : exception;

   Service_Error     : exception;

   type Parameters is limited interface;

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

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

   function To_String (OP : End_Point) return String;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

private

   use Ada.Strings.Unbounded;

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

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

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

   type Manager_Access is access all Manager'Class;

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

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

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

end Security.Auth;

Update the documentation

Update the documentation


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

with MAT.Commands;
with MAT.Targets;
with MAT.Consoles.Text;
procedure Matp is
   Target  : MAT.Targets.Target_Type;
   Console : aliased MAT.Consoles.Text.Console_Type;
begin
   Target.Console (Console'Unchecked_Access);
   Target.Initialize_Options;
   MAT.Commands.Initialize_Files (Target);
   Target.Start;
   MAT.Commands.Interactive (Target);
   Target.Stop;

exception
   when Ada.IO_Exceptions.End_Error | MAT.Targets.Usage_Error =>
      Target.Stop;
end Matp;

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

with MAT.Commands;
with MAT.Targets;
with MAT.Consoles.Text;
procedure Matp is
   Target  : MAT.Targets.Target_Type;
   Console : aliased MAT.Consoles.Text.Console_Type;
begin
   Target.Console (Console'Unchecked_Access);
   Target.Initialize_Options;
   MAT.Commands.Initialize_Files (Target);
   Target.Start;
   Target.Interactive;
   Target.Stop;

exception
   when Ada.IO_Exceptions.End_Error | MAT.Targets.Usage_Error =>
      Target.Stop;
end Matp;

Use MAT.Targets.Interactive procedure

Use MAT.Targets.Interactive procedure


-----------------------------------------------------------------------
--  Util-strings -- Various String Utility
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 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 Ada.Strings.Unbounded;
with Ada.Containers;
with Ada.Containers.Hashed_Maps;
with Ada.Containers.Indefinite_Hashed_Sets;
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;

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

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

Use Hashed_Sets instead of Indefinite_Hashed_Sets


-----------------------------------------------------------------------
--  Util-strings-sets --  Set of strings
--  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 Ada.Strings.Hash;
with Ada.Containers.Indefinite_Hashed_Sets;

--  The <b>Util.Strings.Sets</b> package provides an instantiation
--  of a hashed set with Strings.
package Util.Strings.Sets is new Ada.Containers.Indefinite_Hashed_Sets
  (Element_Type        => String,
   Hash                => Ada.Strings.Hash,
   Equivalent_Elements => "=");

-----------------------------------------------------------------------
--  util-strings-sets --  Set of strings
--  Copyright (C) 2011, 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.Hash;
with Ada.Containers.Indefinite_Hashed_Sets;

--  The <b>Util.Strings.Sets</b> package provides an instantiation
--  of a hashed set with Strings.
package Util.Strings.Sets is new Ada.Containers.Indefinite_Hashed_Sets
  (Element_Type        => String,
   Hash                => Ada.Strings.Hash,
   Equivalent_Elements => "=");

Fix header style

Fix header style