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

with Util.Test_Caller;
with Util.Measures;
with ADO.Caches.Discrete;
with ADO.Caches;
package body ADO.Parameters.Tests is

   use Util.Tests;

   package Int_Cache is new ADO.Caches.Discrete (Element_Type => Integer);

   type Dialect is new ADO.Drivers.Dialects.Dialect with null record;

   --  Check if the string is a reserved keyword.
   overriding
   function Is_Reserved (D    : in Dialect;
                         Name : in String) return Boolean;

   --  Test the Add_Param operation for various types.
   generic
      type T (<>) is private;
      with procedure Add_Param (L : in out ADO.Parameters.Abstract_List;
                                V : in T) is <>;
      Value : T;
      Name  : String;
   procedure Test_Add_Param_T (Tst   : in out Test);

   --  Test the Bind_Param operation for various types.
   generic
      type T (<>) is private;
      with procedure Bind_Param (L : in out ADO.Parameters.Abstract_List;
                                 N : in String;
                                 V : in T) is <>;
      Value : T;
      Name  : String;
   procedure Test_Bind_Param_T (Tst   : in out Test);

   --  Test the Add_Param operation for various types.
   procedure Test_Add_Param_T (Tst   : in out Test) is
      Count : constant Positive := 100;
      SQL   : ADO.Parameters.List;
      S     : Util.Measures.Stamp;
   begin
      for I in 1 .. Count loop
         Add_Param (ADO.Parameters.Abstract_List (SQL), Value);
      end loop;
      Util.Measures.Report (S, "Add_Param " & Name & "(" & Positive'Image (Count) & " calls)");
      Util.Tests.Assert_Equals (Tst, Count, SQL.Length, "Invalid param list for " & Name);
   end Test_Add_Param_T;

   --  Test the Bind_Param operation for various types.
   procedure Test_Bind_Param_T (Tst   : in out Test) is
      Count : constant Positive := 100;
      SQL   : ADO.Parameters.List;
      S     : Util.Measures.Stamp;
   begin
      for I in 1 .. Count loop
         Bind_Param (ADO.Parameters.Abstract_List (SQL), "a_parameter_name", Value);
      end loop;
      Util.Measures.Report (S, "Bind_Param " & Name & "(" & Positive'Image (Count) & " calls)");
      Util.Tests.Assert_Equals (Tst, 1, SQL.Length, "Invalid param list for " & Name);
   end Test_Bind_Param_T;

   procedure Test_Add_Param_Integer is
     new Test_Add_Param_T (Integer, Add_Param, 10, "Integer");
   procedure Test_Add_Param_Long_Long_Integer is
     new Test_Add_Param_T (Long_Long_Integer, Add_Param, 10_000_000_000_000, "Long_Long_Integer");
   procedure Test_Add_Param_Identifier is
     new Test_Add_Param_T (Identifier, Add_Param, 100, "Identifier");
   procedure Test_Add_Param_Boolean is
     new Test_Add_Param_T (Boolean, Add_Param, False, "Boolean");
   procedure Test_Add_Param_String is
     new Test_Add_Param_T (String, Add_Param, "0123456789ABCDEF", "String");
   procedure Test_Add_Param_Calendar is
     new Test_Add_Param_T (Ada.Calendar.Time, Add_Param, Ada.Calendar.Clock, "Time");
   procedure Test_Add_Param_Unbounded_String is
     new Test_Add_Param_T (Unbounded_String, Add_Param, To_Unbounded_String ("0123456789ABCDEF"),
                           "Unbounded_String");

   procedure Test_Bind_Param_Integer is
     new Test_Bind_Param_T (Integer, Bind_Param, 10, "Integer");
   procedure Test_Bind_Param_Long_Long_Integer is
     new Test_Bind_Param_T (Long_Long_Integer, Bind_Param, 10_000_000_000_000,
                            "Long_Long_Integer");
   procedure Test_Bind_Param_Identifier is
     new Test_Bind_Param_T (Identifier, Bind_Param, 100, "Identifier");
   procedure Test_Bind_Param_Entity_Type is
     new Test_Bind_Param_T (Entity_Type, Bind_Param, 100, "Entity_Type");
   procedure Test_Bind_Param_Boolean is
     new Test_Bind_Param_T (Boolean, Bind_Param, False, "Boolean");
   procedure Test_Bind_Param_String is
     new Test_Bind_Param_T (String, Bind_Param, "0123456789ABCDEF", "String");
   procedure Test_Bind_Param_Calendar is
     new Test_Bind_Param_T (Ada.Calendar.Time, Bind_Param, Ada.Calendar.Clock, "Time");
   procedure Test_Bind_Param_Unbounded_String is
     new Test_Bind_Param_T (Unbounded_String, Bind_Param, To_Unbounded_String ("0123456789ABCDEF"),
                           "Unbounded_String");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand",
                       Test_Expand_Sql'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand (invalid params)",
                       Test_Expand_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand (perf)",
                       Test_Expand_Perf'Access);

      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Boolean)",
                       Test_Add_Param_Boolean'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Integer)",
                       Test_Add_Param_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Long_Long_Integer)",
                       Test_Add_Param_Long_Long_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Identifier)",
                       Test_Add_Param_Identifier'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Calendar)",
                       Test_Add_Param_Calendar'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (String)",
                       Test_Add_Param_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Unbounded_String)",
                       Test_Add_Param_Unbounded_String'Access);

      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Boolean)",
                       Test_Bind_Param_Boolean'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Integer)",
                       Test_Bind_Param_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Long_Long_Integer)",
                       Test_Bind_Param_Long_Long_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Identifier)",
                       Test_Bind_Param_Identifier'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Calendar)",
                       Test_Bind_Param_Calendar'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (String)",
                       Test_Bind_Param_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Unbounded_String)",
                       Test_Bind_Param_Unbounded_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Entity_Type)",
                       Test_Bind_Param_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand (cache expander)",
                       Test_Expand_With_Expander'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check if the string is a reserved keyword.
   --  ------------------------------
   overriding
   function Is_Reserved (D    : in Dialect;
                         Name : in String) return Boolean is
      pragma Unreferenced (D, Name);
   begin
      return False;
   end Is_Reserved;

   --  ------------------------------
   --  Test expand SQL with parameters.
   --  ------------------------------
   procedure Test_Expand_Sql (T : in out Test) is
      SQL : ADO.Parameters.List;
      D   : aliased Dialect;

      procedure Check (Pattern : in String; Expect : in String);

      procedure Check (Pattern : in String; Expect : in String) is
         Result : constant String := SQL.Expand (Pattern);
      begin
         Assert_Equals (T, Expect, Result, "Invalid SQL expansion");
      end Check;

   begin
      SQL.Set_Dialect (D'Unchecked_Access);
      SQL.Bind_Param (1, "select '");
      SQL.Bind_Param (2, "from");
      SQL.Bind_Param ("user_id", String '("23"));
      SQL.Bind_Param ("object_23_identifier", Integer (44));
      SQL.Bind_Param ("bool", True);
      SQL.Bind_Param (6, False);
      SQL.Bind_Param ("_date", Ada.Calendar.Clock);
      SQL.Bind_Null_Param ("_null");

      Check ("?", "'select '''");
      Check (":2", "'from'");
      Check (":6", "0");
      Check (":user_id", "'23'");
      Check (":bool", "1");
      Check (":_null", "NULL");

      Check ("select :1 :2 :3 :4 :5 :6", "select 'select ''' 'from' '23' 44 1 0");
      Check ("select ? ? ? ? ? ?", "select 'select ''' 'from' '23' 44 1 0");
      Check ("select ? :2 :user_id :object_23_identifier :bool :6",
             "select 'select ''' 'from' '23' 44 1 0");
   end Test_Expand_Sql;

   --  ------------------------------
   --  Test expand with invalid parameters.
   --  ------------------------------
   procedure Test_Expand_Error (T : in out Test) is
      SQL : ADO.Parameters.List;

      procedure Check (Pattern : in String; Expect : in String);

      procedure Check (Pattern : in String; Expect : in String) is
         Result : constant String := SQL.Expand (Pattern);
      begin
         Assert_Equals (T, Expect, Result, "Invalid SQL expansion");
      end Check;

   begin
      Check (":<", "<");
      Check (":234", "");
      Check (":name", "");
      Check ("select :", "select :");
   end Test_Expand_Error;

   --  ------------------------------
   --  Test expand performance.
   --  ------------------------------
   procedure Test_Expand_Perf (T : in out Test) is
      pragma Unreferenced (T);

      SQL : ADO.Parameters.List;
      D   : aliased Dialect;
   begin
      SQL.Set_Dialect (D'Unchecked_Access);
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            SQL.Bind_Param (I, I);
         end loop;
         Util.Measures.Report (T, "Bind_Param (1000 calls)");
      end;

      declare
         B : constant Unbounded_String
           := To_Unbounded_String ("select t.a, t.b, t.c, t.d, t.e, t.f "
                                   & "from T where t.b = 23");
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := To_String (B);
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand reference To_String");
      end;
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := SQL.Expand ("select t.a, t.b, t.c, t.d, t.e, t.f "
                                                  & "from T where t.b = 23");
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand (1000 calls with 0 parameter)");
      end;
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := SQL.Expand ("select t.a, t.b, t.c, t.d, t.e, t.f "
                                                  & "from T where t.b = :10");
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand (1000 calls with 1 parameter)");
      end;
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := SQL.Expand (":10 :20 :30 :40 :50 :60 :70 :80 :90 :100");
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand (1000 calls with 10 parameters)");
      end;
   end Test_Expand_Perf;

   --  ------------------------------
   --  Test expand with cache expander.
   --  ------------------------------
   procedure Test_Expand_With_Expander (T : in out Test) is
      procedure Check (Content : in String;
                       Expect  : in String);

      SQL : ADO.Parameters.List;
      D   : aliased Dialect;
      C   : aliased ADO.Caches.Cache_Manager;
      M   : access Int_Cache.Cache_Type := new Int_Cache.Cache_Type;
      P   : access Int_Cache.Cache_Type := new Int_Cache.Cache_Type;

      procedure Check (Content : in String;
                       Expect  : in String) is
         S : constant String := SQL.Expand (Content);
      begin
         Util.Tests.Assert_Equals (T, Expect, S, "Invalid expand for SQL '" & Content & "'");
      end Check;

   begin
      C.Add_Cache ("test-group", M.all'Access);
      C.Add_Cache ("G2", P.all'Access);
      SQL.Expander := C'Unchecked_Access;
      M.Insert ("value-1", 123);
      M.Insert ("2", 2);
      M.Insert ("a name", 10);
      P.Insert ("1", 10);
      P.Insert ("a", 0);
      P.Insert ("c", 1);
      SQL.Set_Dialect (D'Unchecked_Access);
      Check ("$test-group[2]", "2");
      Check ("$test-group[a name]", "10");
      Check ("SELECT * FROM user WHERE id = $test-group[2]+$test-group[value-1]",
             "SELECT * FROM user WHERE id = 2+123");
      Check ("SELECT * FROM user WHERE id = $G2[a]+$test-group[value-1]",
             "SELECT * FROM user WHERE id = 0+123");
      P.Insert ("a", 1, True);
      Check ("SELECT * FROM user WHERE id = $G2[a]+$test-group[value-1]",
             "SELECT * FROM user WHERE id = 1+123");
   end Test_Expand_With_Expander;

end ADO.Parameters.Tests;

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

with Util.Test_Caller;
with Util.Measures;
with ADO.Caches.Discrete;
with ADO.Caches;
package body ADO.Parameters.Tests is

   use Util.Tests;

   package Int_Cache is new ADO.Caches.Discrete (Element_Type => Integer);

   type Dialect is new ADO.Drivers.Dialects.Dialect with null record;

   --  Check if the string is a reserved keyword.
   overriding
   function Is_Reserved (D    : in Dialect;
                         Name : in String) return Boolean;

   --  Test the Add_Param operation for various types.
   generic
      type T (<>) is private;
      with procedure Add_Param (L : in out ADO.Parameters.Abstract_List;
                                V : in T) is <>;
      Value : T;
      Name  : String;
   procedure Test_Add_Param_T (Tst   : in out Test);

   --  Test the Bind_Param operation for various types.
   generic
      type T (<>) is private;
      with procedure Bind_Param (L : in out ADO.Parameters.Abstract_List;
                                 N : in String;
                                 V : in T) is <>;
      Value : T;
      Name  : String;
   procedure Test_Bind_Param_T (Tst   : in out Test);

   --  Test the Add_Param operation for various types.
   procedure Test_Add_Param_T (Tst   : in out Test) is
      Count : constant Positive := 100;
      SQL   : ADO.Parameters.List;
      S     : Util.Measures.Stamp;
   begin
      for I in 1 .. Count loop
         Add_Param (ADO.Parameters.Abstract_List (SQL), Value);
      end loop;
      Util.Measures.Report (S, "Add_Param " & Name & "(" & Positive'Image (Count) & " calls)");
      Util.Tests.Assert_Equals (Tst, Count, SQL.Length, "Invalid param list for " & Name);
   end Test_Add_Param_T;

   --  Test the Bind_Param operation for various types.
   procedure Test_Bind_Param_T (Tst   : in out Test) is
      Count : constant Positive := 100;
      SQL   : ADO.Parameters.List;
      S     : Util.Measures.Stamp;
   begin
      for I in 1 .. Count loop
         Bind_Param (ADO.Parameters.Abstract_List (SQL), "a_parameter_name", Value);
      end loop;
      Util.Measures.Report (S, "Bind_Param " & Name & "(" & Positive'Image (Count) & " calls)");
      Util.Tests.Assert_Equals (Tst, 1, SQL.Length, "Invalid param list for " & Name);
   end Test_Bind_Param_T;

   procedure Test_Add_Param_Integer is
     new Test_Add_Param_T (Integer, Add_Param, 10, "Integer");
   procedure Test_Add_Param_Long_Long_Integer is
     new Test_Add_Param_T (Long_Long_Integer, Add_Param, 10_000_000_000_000, "Long_Long_Integer");
   procedure Test_Add_Param_Identifier is
     new Test_Add_Param_T (Identifier, Add_Param, 100, "Identifier");
   procedure Test_Add_Param_Boolean is
     new Test_Add_Param_T (Boolean, Add_Param, False, "Boolean");
   procedure Test_Add_Param_String is
     new Test_Add_Param_T (String, Add_Param, "0123456789ABCDEF", "String");
   procedure Test_Add_Param_Calendar is
     new Test_Add_Param_T (Ada.Calendar.Time, Add_Param, Ada.Calendar.Clock, "Time");
   procedure Test_Add_Param_Unbounded_String is
     new Test_Add_Param_T (Unbounded_String, Add_Param, To_Unbounded_String ("0123456789ABCDEF"),
                           "Unbounded_String");

   procedure Test_Bind_Param_Integer is
     new Test_Bind_Param_T (Integer, Bind_Param, 10, "Integer");
   procedure Test_Bind_Param_Long_Long_Integer is
     new Test_Bind_Param_T (Long_Long_Integer, Bind_Param, 10_000_000_000_000,
                            "Long_Long_Integer");
   procedure Test_Bind_Param_Identifier is
     new Test_Bind_Param_T (Identifier, Bind_Param, 100, "Identifier");
   procedure Test_Bind_Param_Entity_Type is
     new Test_Bind_Param_T (Entity_Type, Bind_Param, 100, "Entity_Type");
   procedure Test_Bind_Param_Boolean is
     new Test_Bind_Param_T (Boolean, Bind_Param, False, "Boolean");
   procedure Test_Bind_Param_String is
     new Test_Bind_Param_T (String, Bind_Param, "0123456789ABCDEF", "String");
   procedure Test_Bind_Param_Calendar is
     new Test_Bind_Param_T (Ada.Calendar.Time, Bind_Param, Ada.Calendar.Clock, "Time");
   procedure Test_Bind_Param_Unbounded_String is
     new Test_Bind_Param_T (Unbounded_String, Bind_Param, To_Unbounded_String ("0123456789ABCDEF"),
                           "Unbounded_String");

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand",
                       Test_Expand_Sql'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand (invalid params)",
                       Test_Expand_Error'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand (perf)",
                       Test_Expand_Perf'Access);

      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Boolean)",
                       Test_Add_Param_Boolean'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Integer)",
                       Test_Add_Param_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Long_Long_Integer)",
                       Test_Add_Param_Long_Long_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Identifier)",
                       Test_Add_Param_Identifier'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Calendar)",
                       Test_Add_Param_Calendar'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (String)",
                       Test_Add_Param_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Add_Param (Unbounded_String)",
                       Test_Add_Param_Unbounded_String'Access);

      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Boolean)",
                       Test_Bind_Param_Boolean'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Integer)",
                       Test_Bind_Param_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Long_Long_Integer)",
                       Test_Bind_Param_Long_Long_Integer'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Identifier)",
                       Test_Bind_Param_Identifier'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Calendar)",
                       Test_Bind_Param_Calendar'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (String)",
                       Test_Bind_Param_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Unbounded_String)",
                       Test_Bind_Param_Unbounded_String'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Bind_Param (Entity_Type)",
                       Test_Bind_Param_Entity_Type'Access);
      Caller.Add_Test (Suite, "Test ADO.Parameters.Expand (cache expander)",
                       Test_Expand_With_Expander'Access);
   end Add_Tests;

   --  ------------------------------
   --  Check if the string is a reserved keyword.
   --  ------------------------------
   overriding
   function Is_Reserved (D    : in Dialect;
                         Name : in String) return Boolean is
      pragma Unreferenced (D, Name);
   begin
      return False;
   end Is_Reserved;

   --  ------------------------------
   --  Test expand SQL with parameters.
   --  ------------------------------
   procedure Test_Expand_Sql (T : in out Test) is
      SQL : ADO.Parameters.List;
      D   : aliased Dialect;

      procedure Check (Pattern : in String; Expect : in String);

      procedure Check (Pattern : in String; Expect : in String) is
         Result : constant String := SQL.Expand (Pattern);
      begin
         Assert_Equals (T, Expect, Result, "Invalid SQL expansion");
      end Check;

   begin
      SQL.Set_Dialect (D'Unchecked_Access);
      SQL.Bind_Param (1, "select '");
      SQL.Bind_Param (2, "from");
      SQL.Bind_Param ("user_id", String '("23"));
      SQL.Bind_Param ("object_23_identifier", Integer (44));
      SQL.Bind_Param ("bool", True);
      SQL.Bind_Param (6, False);
      SQL.Bind_Param ("_date", Ada.Calendar.Clock);
      SQL.Bind_Null_Param ("_null");

      Check ("?", "'select '''");
      Check (":2", "'from'");
      Check (":6", "0");
      Check (":user_id", "'23'");
      Check (":bool", "1");
      Check (":_null", "NULL");

      Check ("select :1 :2 :3 :4 :5 :6", "select 'select ''' 'from' '23' 44 1 0");
      Check ("select ? ? ? ? ? ?", "select 'select ''' 'from' '23' 44 1 0");
      Check ("select ? :2 :user_id :object_23_identifier :bool :6",
             "select 'select ''' 'from' '23' 44 1 0");
      Check ("select \:1 \:2 \:3 \:4 \:5 \:6", "select :1 :2 :3 :4 :5 :6");
   end Test_Expand_Sql;

   --  ------------------------------
   --  Test expand with invalid parameters.
   --  ------------------------------
   procedure Test_Expand_Error (T : in out Test) is
      SQL : ADO.Parameters.List;

      procedure Check (Pattern : in String; Expect : in String);

      procedure Check (Pattern : in String; Expect : in String) is
         Result : constant String := SQL.Expand (Pattern);
      begin
         Assert_Equals (T, Expect, Result, "Invalid SQL expansion");
      end Check;

   begin
      Check (":<", "<");
      Check (":234", "");
      Check (":name", "");
      Check ("select :", "select :");
   end Test_Expand_Error;

   --  ------------------------------
   --  Test expand performance.
   --  ------------------------------
   procedure Test_Expand_Perf (T : in out Test) is
      pragma Unreferenced (T);

      SQL : ADO.Parameters.List;
      D   : aliased Dialect;
   begin
      SQL.Set_Dialect (D'Unchecked_Access);
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            SQL.Bind_Param (I, I);
         end loop;
         Util.Measures.Report (T, "Bind_Param (1000 calls)");
      end;

      declare
         B : constant Unbounded_String
           := To_Unbounded_String ("select t.a, t.b, t.c, t.d, t.e, t.f "
                                   & "from T where t.b = 23");
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := To_String (B);
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand reference To_String");
      end;
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := SQL.Expand ("select t.a, t.b, t.c, t.d, t.e, t.f "
                                                  & "from T where t.b = 23");
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand (1000 calls with 0 parameter)");
      end;
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := SQL.Expand ("select t.a, t.b, t.c, t.d, t.e, t.f "
                                                  & "from T where t.b = :10");
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand (1000 calls with 1 parameter)");
      end;
      declare
         T : Util.Measures.Stamp;
      begin
         for I in 1 .. 1_000 loop
            declare
               S : constant String := SQL.Expand (":10 :20 :30 :40 :50 :60 :70 :80 :90 :100");
               pragma Unreferenced (S);
            begin
               null;
            end;
         end loop;
         Util.Measures.Report (T, "Expand (1000 calls with 10 parameters)");
      end;
   end Test_Expand_Perf;

   --  ------------------------------
   --  Test expand with cache expander.
   --  ------------------------------
   procedure Test_Expand_With_Expander (T : in out Test) is
      procedure Check (Content : in String;
                       Expect  : in String);

      SQL : ADO.Parameters.List;
      D   : aliased Dialect;
      C   : aliased ADO.Caches.Cache_Manager;
      M   : access Int_Cache.Cache_Type := new Int_Cache.Cache_Type;
      P   : access Int_Cache.Cache_Type := new Int_Cache.Cache_Type;

      procedure Check (Content : in String;
                       Expect  : in String) is
         S : constant String := SQL.Expand (Content);
      begin
         Util.Tests.Assert_Equals (T, Expect, S, "Invalid expand for SQL '" & Content & "'");
      end Check;

   begin
      C.Add_Cache ("test-group", M.all'Access);
      C.Add_Cache ("G2", P.all'Access);
      SQL.Expander := C'Unchecked_Access;
      M.Insert ("value-1", 123);
      M.Insert ("2", 2);
      M.Insert ("a name", 10);
      P.Insert ("1", 10);
      P.Insert ("a", 0);
      P.Insert ("c", 1);
      SQL.Set_Dialect (D'Unchecked_Access);
      Check ("$test-group[2]", "2");
      Check ("$test-group[a name]", "10");
      Check ("SELECT * FROM user WHERE id = $test-group[2]+$test-group[value-1]",
             "SELECT * FROM user WHERE id = 2+123");
      Check ("SELECT * FROM user WHERE id = $G2[a]+$test-group[value-1]",
             "SELECT * FROM user WHERE id = 0+123");
      P.Insert ("a", 1, True);
      Check ("SELECT * FROM user WHERE id = $G2[a]+$test-group[value-1]",
             "SELECT * FROM user WHERE id = 1+123");
      Check ("SELECT * FROM user WHERE id = 2$G2[titi]+$test[value-1]1",
             "SELECT * FROM user WHERE id = 2+1");
   end Test_Expand_With_Expander;

end ADO.Parameters.Tests;

Add more tests for the SQL expander

Add more tests for the SQL expander


------------------------------------------------------------------------------
-- Copyright (c) 2015, 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Escapes provdes primitives for HTML-style escaping.          --
------------------------------------------------------------------------------

with Ada.Streams;
with Natools.S_Expressions.Atom_Refs;

package Natools.Web.Escapes is
   pragma Preelaborate;

   type Escape_Set is record
      Gt_Lt : Boolean := False;
      Amp : Boolean := False;
      Apos : Boolean := False;
      Quot : Boolean := False;
   end record;

   function Is_Empty (Set : in Escape_Set) return Boolean
     is (Set.Gt_Lt or Set.Amp or Set.Apos or Set.Quot);

   HTML_Attribute : constant Escape_Set;
   HTML_Body : constant Escape_Set;

   function Escaped_Length
     (Data : in S_Expressions.Atom;
      Set : in Escape_Set)
     return S_Expressions.Count;
      --  Return the number of octet in the escaped version of Data

   procedure Write
     (Output : in out Ada.Streams.Root_Stream_Type'Class;
      Data : in S_Expressions.Atom;
      Set : in Escape_Set);
      --  Escape octets from Data in Set, and write them into Output

   procedure Write
     (Output : in out Ada.Streams.Root_Stream_Type'Class;
      Text : in String;
      Set : in Escape_Set);
      --  Escape octets from Text in Set, and write them into Output

   function Escape
     (Data : in S_Expressions.Atom;
      Set : in Escape_Set)
     return S_Expressions.Atom;
      --  Escape Data and return it directly as an atom

   function Escape
     (Data : in S_Expressions.Atom;
      Set : in Escape_Set)
     return S_Expressions.Atom_Refs.Immutable_Reference;
      --  Escape Data and return it in a newly-created reference

   function Escape
     (Data : in S_Expressions.Atom_Refs.Immutable_Reference;
      Set : in Escape_Set)
     return S_Expressions.Atom_Refs.Immutable_Reference;
      --  Escape Data if needed, otherwise duplicate the reference

private

   type Atom_Stream (Data : not null access S_Expressions.Atom)
     is new Ada.Streams.Root_Stream_Type
   with record
      Last : S_Expressions.Offset;
   end record;

   overriding procedure Read
     (Stream : in out Atom_Stream;
      Item : out Ada.Streams.Stream_Element_Array;
      Last : out Ada.Streams.Stream_Element_Offset);

   overriding procedure Write
     (Stream : in out Atom_Stream;
      Item : in Ada.Streams.Stream_Element_Array);

   type Count_Stream is new Ada.Streams.Root_Stream_Type with record
      Count : S_Expressions.Count := 0;
   end record;

   overriding procedure Read
     (Stream : in out Count_Stream;
      Item : out Ada.Streams.Stream_Element_Array;
      Last : out Ada.Streams.Stream_Element_Offset);

   overriding procedure Write
     (Stream : in out Count_Stream;
      Item : in Ada.Streams.Stream_Element_Array);

   type Octet_Set is array (S_Expressions.Octet) of Boolean;

   procedure Update_Set (Octets : in out Octet_Set; Set : in Escape_Set);
      --  Convert an escape set to an octet set

   HTML_Attribute : constant Escape_Set := (others => True);

   HTML_Body : constant Escape_Set
     := (Gt_Lt | Amp => True, others => False);

end Natools.Web.Escapes;

------------------------------------------------------------------------------
-- Copyright (c) 2015, 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.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.Web.Escapes provdes primitives for HTML-style escaping.          --
------------------------------------------------------------------------------

with Ada.Streams;
with Natools.S_Expressions.Atom_Refs;

package Natools.Web.Escapes is
   pragma Preelaborate;

   type Escape_Set is record
      Gt_Lt : Boolean := False;
      Amp : Boolean := False;
      Apos : Boolean := False;
      Quot : Boolean := False;
   end record;

   function Is_Empty (Set : in Escape_Set) return Boolean
     is (Set.Gt_Lt or Set.Amp or Set.Apos or Set.Quot);

   HTML_Attribute : constant Escape_Set;
   HTML_Body : constant Escape_Set;

   function Escaped_Length
     (Data : in S_Expressions.Atom;
      Set : in Escape_Set)
     return S_Expressions.Count;
      --  Return the number of octet in the escaped version of Data

   procedure Write
     (Output : in out Ada.Streams.Root_Stream_Type'Class;
      Data : in S_Expressions.Atom;
      Set : in Escape_Set);
      --  Escape octets from Data in Set, and write them into Output

   procedure Write
     (Output : in out Ada.Streams.Root_Stream_Type'Class;
      Text : in String;
      Set : in Escape_Set);
      --  Escape octets from Text in Set, and write them into Output

   function Escape
     (Data : in S_Expressions.Atom;
      Set : in Escape_Set)
     return S_Expressions.Atom;
      --  Escape Data and return it directly as an atom

   function Escape
     (Data : in S_Expressions.Atom;
      Set : in Escape_Set)
     return S_Expressions.Atom_Refs.Immutable_Reference;
      --  Escape Data and return it in a newly-created reference

   function Escape
     (Data : in S_Expressions.Atom_Refs.Immutable_Reference;
      Set : in Escape_Set)
     return S_Expressions.Atom_Refs.Immutable_Reference;
      --  Escape Data if needed, otherwise duplicate the reference

private

   type Atom_Stream (Data : not null access S_Expressions.Atom)
     is new Ada.Streams.Root_Stream_Type
   with record
      Last : S_Expressions.Offset;
   end record;

   overriding procedure Read
     (Stream : in out Atom_Stream;
      Item : out Ada.Streams.Stream_Element_Array;
      Last : out Ada.Streams.Stream_Element_Offset);

   overriding procedure Write
     (Stream : in out Atom_Stream;
      Item : in Ada.Streams.Stream_Element_Array);

   type Count_Stream is new Ada.Streams.Root_Stream_Type with record
      Count : S_Expressions.Count := 0;
   end record;

   overriding procedure Read
     (Stream : in out Count_Stream;
      Item : out Ada.Streams.Stream_Element_Array;
      Last : out Ada.Streams.Stream_Element_Offset);

   overriding procedure Write
     (Stream : in out Count_Stream;
      Item : in Ada.Streams.Stream_Element_Array);

   type Octet_Set is array (S_Expressions.Octet) of Boolean;

   procedure Update_Set (Octets : in out Octet_Set; Set : in Escape_Set);
      --  Convert an escape set to an octet set

   HTML_Attribute : constant Escape_Set := (Apos => False, others => True);

   HTML_Body : constant Escape_Set
     := (Gt_Lt | Amp => True, others => False);

end Natools.Web.Escapes;

escapes: remove `apos` from HTML attribute escapes to conform to strict HTML 4.01


-----------------------------------------------------------------------
--  EL.Expressions -- Expression Language
--  Copyright (C) 2009, 2010 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 EL.Expressions.Nodes;
with EL.Expressions.Parser;
with Util.Concurrent.Counters;
package body EL.Expressions is

   --  ------------------------------
   --  Check whether the expression is a holds a constant value.
   --  ------------------------------
   function Is_Constant (Expr : Expression'Class) return Boolean is
   begin
      return Expr.Node = null;
   end Is_Constant;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : Expression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Node = null then
         return Expr.Value;
      end if;
      return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
   end Get_Value;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : ValueExpression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Bean = null then
         if Expr.Node = null then
            return Expr.Value;
         else
            return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
         end if;
      end if;
      return To_Object (Expr.Bean);
   end Get_Value;

   --  ------------------------------
   --  Set the value of the expression to the given object value.
   --  ------------------------------
   procedure Set_Value (Expr    : in out ValueExpression;
                        Context : in ELContext'Class;
                        Value   : in Object) is
   begin
      Expr.Value := Value;
   end Set_Value;

   --  ------------------------------
   --  Returns true if the expression is read-only.
   --  ------------------------------
   function Is_Readonly (Expr : in ValueExpression) return Boolean is
   begin
      if Expr.Bean = null then
         return True;
      end if;
      return not (Expr.Bean.all in EL.Beans.Bean'Class);
   end Is_Readonly;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      Result : Expression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      if Node /= null then
         Result.Node := Node.all'Access;
      end if;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   function Reduce_Expression (Expr    : Expression;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      use Ada.Finalization;
   begin
      if Expr.Node = null then
         return Expr;
      end if;
      declare
         Result : constant Reduction := Expr.Node.Reduce (Context);
      begin
         return Expression '(Controlled with
                             Node => Result.Node,
                             Value => Result.Value);
      end;
   end Reduce_Expression;

   function Create_ValueExpression (Bean : access EL.Beans.Readonly_Bean'Class)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Bean := Bean;
      return Result;
   end Create_ValueExpression;

   function Create_ValueExpression (Bean : EL.Objects.Object)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Value := Bean;
      return Result;
   end Create_ValueExpression;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return ValueExpression is
      Result : ValueExpression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   overriding
   function Reduce_Expression (Expr    : ValueExpression;
                               Context : ELContext'Class)
                               return ValueExpression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

   procedure Adjust (Object : in out Expression) is
   begin
      if Object.Node /= null then
         Util.Concurrent.Counters.Increment (Object.Node.Ref_Counter);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Expression) is
      Node    : EL.Expressions.Nodes.ELNode_Access;
      Is_Zero : Boolean;
   begin
      if Object.Node /= null then
         Node := Object.Node.all'Access;
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Is_Zero);
         if Is_Zero then
            EL.Expressions.Nodes.Delete (Node);
            Object.Node := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Evaluate the method expression and return the object and method
   --  binding to execute the method.  The result contains a pointer
   --  to the bean object and a method binding.  The method binding
   --  contains the information to invoke the method
   --  (such as an access to the function or procedure).
   --  Raises the Invalid_Method exception if the method
   --  cannot be resolved.
   --  ------------------------------
   function Get_Method_Info (Expr    : Method_Expression;
                             Context : ELContext'Class)
                             return Method_Info is
      use EL.Expressions.Nodes;
   begin
      if Expr.Node = null then
         raise Invalid_Expression with "Method expression is empty";
      end if;
      declare
         Node : constant ELValue_Access := ELValue'Class (Expr.Node.all)'Access;
      begin
         return Node.Get_Method_Info (Context);
      end;
   end Get_Method_Info;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  The context is used to resolve the functions.  Variables will be
   --  resolved during evaluation of the expression.
   --  Raises Invalid_Expression if the expression is invalid.
   --  ------------------------------
   overriding
   function Create_Expression (Expr    : String;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
     use type EL.Expressions.Nodes.ELNode_Access;

     Result : Method_Expression;
     Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);

      --  The root of the method expression must be an ELValue node.
      if Node = null or else not (Node.all in Nodes.ELValue'Class) then
         raise Invalid_Expression with "Expression is not a method expression";
      end if;
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   overriding
   function Reduce_Expression (Expr    : Method_Expression;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

end EL.Expressions;

-----------------------------------------------------------------------
--  EL.Expressions -- Expression Language
--  Copyright (C) 2009, 2010 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 EL.Expressions.Nodes;
with EL.Expressions.Parser;
with Util.Concurrent.Counters;
package body EL.Expressions is

   --  ------------------------------
   --  Check whether the expression is a holds a constant value.
   --  ------------------------------
   function Is_Constant (Expr : Expression'Class) return Boolean is
   begin
      return Expr.Node = null;
   end Is_Constant;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : Expression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Node = null then
         return Expr.Value;
      end if;
      return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
   end Get_Value;

   --  ------------------------------
   --  Get the value of the expression using the given expression context.
   --  ------------------------------
   function Get_Value (Expr    : ValueExpression;
                       Context : ELContext'Class) return Object is
   begin
      if Expr.Bean = null then
         if Expr.Node = null then
            return Expr.Value;
         else
            return EL.Expressions.Nodes.Get_Value (Expr.Node.all, Context);
         end if;
      end if;
      return To_Object (Expr.Bean);
   end Get_Value;

   --  ------------------------------
   --  Set the value of the expression to the given object value.
   --  ------------------------------
   procedure Set_Value (Expr    : in out ValueExpression;
                        Context : in ELContext'Class;
                        Value   : in Object) is
   begin
      Expr.Value := Value;
   end Set_Value;

   --  ------------------------------
   --  Returns true if the expression is read-only.
   --  ------------------------------
   function Is_Readonly (Expr : in ValueExpression) return Boolean is
   begin
      if Expr.Bean = null then
         return True;
      end if;
      return not (Expr.Bean.all in EL.Beans.Bean'Class);
   end Is_Readonly;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      Result : Expression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      if Node /= null then
         Result.Node := Node.all'Access;
      end if;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   function Reduce_Expression (Expr    : Expression;
                               Context : ELContext'Class)
                               return Expression is
      use EL.Expressions.Nodes;
      use Ada.Finalization;
   begin
      if Expr.Node = null then
         return Expr;
      end if;
      declare
         Result : constant Reduction := Expr.Node.Reduce (Context);
      begin
         return Expression '(Controlled with
                             Node => Result.Node,
                             Value => Result.Value);
      end;
   end Reduce_Expression;

   function Create_ValueExpression (Bean : access EL.Beans.Readonly_Bean'Class)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Bean := Bean;
      return Result;
   end Create_ValueExpression;

   function Create_ValueExpression (Bean : EL.Objects.Object)
                                    return ValueExpression is
      Result : ValueExpression;
   begin
      Result.Value := Bean;
      return Result;
   end Create_ValueExpression;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  ------------------------------
   function Create_Expression (Expr    : String;
                               Context : ELContext'Class)
                               return ValueExpression is
      Result : ValueExpression;
      Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   overriding
   function Reduce_Expression (Expr    : ValueExpression;
                               Context : ELContext'Class)
                               return ValueExpression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

   procedure Adjust (Object : in out Expression) is
   begin
      if Object.Node /= null then
         Util.Concurrent.Counters.Increment (Object.Node.Ref_Counter);
      end if;
   end Adjust;

   procedure Finalize (Object : in out Expression) is
      Node    : EL.Expressions.Nodes.ELNode_Access;
      Is_Zero : Boolean;
   begin
      if Object.Node /= null then
         Node := Object.Node.all'Access;
         Util.Concurrent.Counters.Decrement (Node.Ref_Counter, Is_Zero);
         if Is_Zero then
            EL.Expressions.Nodes.Delete (Node);
            Object.Node := null;
         end if;
      end if;
   end Finalize;

   --  ------------------------------
   --  Evaluate the method expression and return the object and method
   --  binding to execute the method.  The result contains a pointer
   --  to the bean object and a method binding.  The method binding
   --  contains the information to invoke the method
   --  (such as an access to the function or procedure).
   --  Raises the Invalid_Method exception if the method
   --  cannot be resolved.
   --  ------------------------------
   function Get_Method_Info (Expr    : Method_Expression;
                             Context : ELContext'Class)
                             return Method_Info is
      use EL.Expressions.Nodes;
   begin
      if Expr.Node = null then
         raise Invalid_Expression with "Method expression is empty";
      end if;
      declare
         Node : constant ELValue_Access := ELValue'Class (Expr.Node.all)'Access;
      begin
         return Node.Get_Method_Info (Context);
      end;
   end Get_Method_Info;

   --  ------------------------------
   --  Parse an expression and return its representation ready for evaluation.
   --  The context is used to resolve the functions.  Variables will be
   --  resolved during evaluation of the expression.
   --  Raises Invalid_Expression if the expression is invalid.
   --  ------------------------------
   overriding
   function Create_Expression (Expr    : String;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
     use type EL.Expressions.Nodes.ELNode_Access;

     Result : Method_Expression;
     Node   : EL.Expressions.Nodes.ELNode_Access;
   begin
      EL.Expressions.Parser.Parse (Expr => Expr, Context => Context, Result => Node);

      --  The root of the method expression must be an ELValue node.
      if Node = null or else not (Node.all in Nodes.ELValue'Class) then
         EL.Expressions.Nodes.Delete (Node);
         raise Invalid_Expression with "Expression is not a method expression";
      end if;
      Result.Node := Node.all'Access;
      return Result;
   end Create_Expression;

   --  ------------------------------
   --  Reduce the expression by eliminating known variables and computing
   --  constant expressions.  The result expression is either another
   --  expression or a computed constant value.
   --  ------------------------------
   overriding
   function Reduce_Expression (Expr    : Method_Expression;
                               Context : EL.Contexts.ELContext'Class)
                               return Method_Expression is
      pragma Unreferenced (Context);
   begin
      return Expr;
   end Reduce_Expression;

end EL.Expressions;

Fix memory leak if the method expression is a valid EL expression but not a method expression


-----------------------------------------------------------------------
--  html-pages -- HTML Page Components
--  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 Util.Strings;
with ASF.Utils;

--  The <b>Pages</b> package implements various components used when building an HTML page.
--
package body ASF.Components.Html.Pages is

   BODY_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   HEAD_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Head Component
   --  ------------------------------

   --  ------------------------------
   --  Encode the HTML head element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIHead;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("head");
      UI.Render_Attributes (Context, HEAD_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML head element.  Before closing the head, generate the resource
   --  links that have been queued for the head generation.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIHead;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("head");
   end Encode_End;

   --  ------------------------------
   --  Encode the HTML body element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIBody;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("body");
      UI.Render_Attributes (Context, BODY_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML body element.  Before closing the body, generate the inclusion
   --  of differed resources (pending javascript, inclusion of javascript files)
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIBody;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("body");
   end Encode_End;

begin
   Utils.Set_Head_Attributes (HEAD_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (BODY_ATTRIBUTE_NAMES);
   Utils.Set_Body_Attributes (BODY_ATTRIBUTE_NAMES);
end ASF.Components.Html.Pages;

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

with Util.Strings;
with Util.Beans.Objects;

with ASF.Utils;

--  The <b>Pages</b> package implements various components used when building an HTML page.
--
package body ASF.Components.Html.Pages is

   BODY_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   HEAD_ATTRIBUTE_NAMES  : Util.Strings.String_Set.Set;

   --  ------------------------------
   --  Head Component
   --  ------------------------------

   --  ------------------------------
   --  Encode the HTML head element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIHead;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("head");
      UI.Render_Attributes (Context, HEAD_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML head element.  Before closing the head, generate the resource
   --  links that have been queued for the head generation.
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIHead;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("head");
   end Encode_End;

   --  ------------------------------
   --  Encode the HTML body element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIBody;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Start_Element ("body");
      UI.Render_Attributes (Context, BODY_ATTRIBUTE_NAMES, Writer);
   end Encode_Begin;

   --  ------------------------------
   --  Terminate the HTML body element.  Before closing the body, generate the inclusion
   --  of differed resources (pending javascript, inclusion of javascript files)
   --  ------------------------------
   overriding
   procedure Encode_End (UI      : in UIBody;
                         Context : in out Contexts.Faces.Faces_Context'Class) is
      pragma Unreferenced (UI);

      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      Writer.Write_Scripts;
      Writer.End_Element ("body");
   end Encode_End;

   --  ------------------------------
   --  Encode the DOCTYPE element.
   --  ------------------------------
   overriding
   procedure Encode_Begin (UI      : in UIDoctype;
                           Context : in out Contexts.Faces.Faces_Context'Class) is
      Writer : constant Response_Writer_Access := Context.Get_Response_Writer;
   begin
      if UI.Is_Rendered (Context) then
         Writer.Write ("<!DOCTYPE ");
         Writer.Write (UI.Get_Attribute ("rootElement", Context, ""));
         declare
            Public : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "public");
            System : constant Util.Beans.Objects.Object := UI.Get_Attribute (Context, "system");
         begin
            if not Util.Beans.Objects.Is_Null (Public) then
               Writer.Write (" PUBLIC """);
               Writer.Write (Public);
               Writer.Write ('"');
            end if;
            if not Util.Beans.Objects.Is_Null (System) then
               Writer.Write (" """);
               Writer.Write (System);
               Writer.Write ('"');
            end if;
         end;
         Writer.Write ('>');
      end if;
   end Encode_Begin;

begin
   Utils.Set_Head_Attributes (HEAD_ATTRIBUTE_NAMES);
   Utils.Set_Text_Attributes (BODY_ATTRIBUTE_NAMES);
   Utils.Set_Body_Attributes (BODY_ATTRIBUTE_NAMES);
end ASF.Components.Html.Pages;

Implement the UIDoctype component with the <!DOCTYPE> generation according to the <h:doctype> JSF 2.2 standard


--  Copyright (c) 2013 Felix Krause <contact@flyx.org>
--
--  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 Interfaces.C.Strings;

with GL.API;
with GL.Enums.Getter;
with GL.Errors;

package body GL.Context is

   function Major_Version return Int is
      Result : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Major_Version, Result'Access);
      Raise_Exception_On_OpenGL_Error;
      return Result;
   end Major_Version;

   function Minor_Version return Int is
      Result : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Minor_Version, Result'Access);
      Raise_Exception_On_OpenGL_Error;
      return Result;
   end Minor_Version;

   function Version_String return String is
   begin
      return C.Strings.Value (API.Get_String (Enums.Getter.Version));
   end Version_String;

   function Vendor return String is
   begin
      return C.Strings.Value (API.Get_String (Enums.Getter.Vendor));
   end Vendor;

   function Renderer return String is
   begin
      return C.Strings.Value (API.Get_String (Enums.Getter.Renderer));
   end Renderer;

   function Extensions return String_List is
      use Ada.Strings.Unbounded;
      use type Errors.Error_Code;
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Extensions, Count'Access);
      Raise_Exception_On_OpenGL_Error;

      pragma Assert (API.Get_Error = Errors.No_Error);
      --  We are on OpenGL 3

      return List : String_List (1 .. Positive (Count)) do
         for I in List'Range loop
            List (I) := To_Unbounded_String
              (C.Strings.Value (API.Get_String_I
                                (Enums.Getter.Extensions, UInt (I - 1))));
         end loop;
      end return;
   end Extensions;

   function Has_Extension (Name : String) return Boolean is
      use type Errors.Error_Code;
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Extensions, Count'Access);
      Raise_Exception_On_OpenGL_Error;

      pragma Assert (API.Get_Error = Errors.No_Error);
      --  We are on OpenGL 3

      for I in 1 .. Count loop
         declare
            Extension : constant String := C.Strings.Value
              (API.Get_String_I (Enums.Getter.Extensions, UInt (I - 1)));
         begin
            if Extension = Name then
               return True;
            end if;
         end;
      end loop;
      return False;
   end Has_Extension;

   function Primary_Shading_Language_Version return String is
      Result : constant String := C.Strings.Value
        (API.Get_String (Enums.Getter.Shading_Language_Version));
   begin
      Raise_Exception_On_OpenGL_Error;
      return Result;
   end Primary_Shading_Language_Version;

   function Supported_Shading_Language_Versions return String_List is
      use Ada.Strings.Unbounded;
      use type Errors.Error_Code;
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Shading_Language_Versions, Count'Access);
      if API.Get_Error = Errors.Invalid_Enum then
         raise Feature_Not_Supported_Exception;
      end if;
      return List : String_List (1 .. Positive (Count)) do
         for I in List'Range loop
            List (I) := To_Unbounded_String
              (C.Strings.Value (API.Get_String_I (
               Enums.Getter.Shading_Language_Version, UInt (I - 1))));
         end loop;
      end return;
   end Supported_Shading_Language_Versions;

   function Supports_Shading_Language_Version (Name : String) return Boolean is
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Shading_Language_Versions, Count'Access);
      Raise_Exception_On_OpenGL_Error;
      for I in 1 .. Count loop
         if C.Strings.Value
           (API.Get_String_I (Enums.Getter.Shading_Language_Version,
                              UInt (I - 1))) = Name
         then
            return True;
         end if;
      end loop;
      return False;
   end Supports_Shading_Language_Version;

end GL.Context;

--  Copyright (c) 2013 Felix Krause <contact@flyx.org>
--
--  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 Interfaces.C.Strings;

with GL.API;
with GL.Enums.Getter;
with GL.Errors;

package body GL.Context is

   function Extension (Index : Positive) return String is
     (C.Strings.Value (API.Get_String_I (Enums.Getter.Extensions, UInt (Index - 1))));

   function GLSL_Version (Index : Positive) return String is
     (C.Strings.Value (API.Get_String_I (Enums.Getter.Shading_Language_Version, UInt (Index - 1))));

   function Major_Version return Int is
      Result : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Major_Version, Result'Access);
      Raise_Exception_On_OpenGL_Error;
      return Result;
   end Major_Version;

   function Minor_Version return Int is
      Result : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Minor_Version, Result'Access);
      Raise_Exception_On_OpenGL_Error;
      return Result;
   end Minor_Version;

   function Version_String return String is
   begin
      return C.Strings.Value (API.Get_String (Enums.Getter.Version));
   end Version_String;

   function Vendor return String is
   begin
      return C.Strings.Value (API.Get_String (Enums.Getter.Vendor));
   end Vendor;

   function Renderer return String is
   begin
      return C.Strings.Value (API.Get_String (Enums.Getter.Renderer));
   end Renderer;

   function Extensions return String_List is
      use Ada.Strings.Unbounded;
      use type Errors.Error_Code;
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Extensions, Count'Access);
      Raise_Exception_On_OpenGL_Error;

      pragma Assert (API.Get_Error = Errors.No_Error);
      --  We are on OpenGL 3

      return List : String_List (1 .. Positive (Count)) do
         for I in List'Range loop
            List (I) := To_Unbounded_String (Extension (I));
         end loop;
      end return;
   end Extensions;

   function Has_Extension (Name : String) return Boolean is
      use type Errors.Error_Code;
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Extensions, Count'Access);
      Raise_Exception_On_OpenGL_Error;

      pragma Assert (API.Get_Error = Errors.No_Error);
      --  We are on OpenGL 3

      return (for some I in 1 .. Positive (Count) => Extension (I) = Name);
   end Has_Extension;

   function Primary_Shading_Language_Version return String is
      Result : constant String := C.Strings.Value
        (API.Get_String (Enums.Getter.Shading_Language_Version));
   begin
      Raise_Exception_On_OpenGL_Error;
      return Result;
   end Primary_Shading_Language_Version;

   function Supported_Shading_Language_Versions return String_List is
      use Ada.Strings.Unbounded;
      use type Errors.Error_Code;
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Shading_Language_Versions, Count'Access);
      if API.Get_Error = Errors.Invalid_Enum then
         raise Feature_Not_Supported_Exception;
      end if;
      return List : String_List (1 .. Positive (Count)) do
         for I in List'Range loop
            List (I) := To_Unbounded_String (GLSL_Version (I));
         end loop;
      end return;
   end Supported_Shading_Language_Versions;

   function Supports_Shading_Language_Version (Name : String) return Boolean is
      Count : aliased Int;
   begin
      API.Get_Integer (Enums.Getter.Num_Shading_Language_Versions, Count'Access);
      Raise_Exception_On_OpenGL_Error;

      return (for some I in 1 .. Positive (Count) => GLSL_Version (I) = Name);
   end Supports_Shading_Language_Version;

end GL.Context;

gl: Use Ada 2012 quantified expressions in GL.Context

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


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

package body Security.OAuth.File_Registry is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   overriding
   function Get_Name (From : in File_Principal) return String is
   begin
      return To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   --  ------------------------------
   overriding
   function Find_Application (Realm     : in File_Application_Manager;
                              Client_Id : in String) return Servers.Application'Class is
      Pos : constant Application_Maps.Cursor := Realm.Applications.Find (Client_Id);
   begin
      if not Application_Maps.Has_Element (Pos) then
         raise Servers.Invalid_Application;
      end if;
      return Application_Maps.Element (Pos);
   end Find_Application;

   --  ------------------------------
   --  Add the application to the application repository.
   --  ------------------------------
   procedure Add_Application (Realm : in out File_Application_Manager;
                              App   : in Servers.Application) is
   begin
      Realm.Applications.Include (App.Get_Application_Identifier, App);
   end Add_Application;

   --  ------------------------------
   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   --  ------------------------------
   overriding
   procedure Authenticate (Realm     : in out File_Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is
      Pos : constant Token_Maps.Cursor := Realm.Tokens.Find (Token);
   begin
      if Token_Maps.Has_Element (Pos) then
         Auth := Token_Maps.Element (Pos).all'Access;
      else
         Auth := null;
      end if;
      Cacheable := True;
   end Authenticate;

   --  ------------------------------
   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   --  ------------------------------
   overriding
   function Authorize (Realm : in File_Realm_Manager;
                       App   : in Servers.Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is
   begin
      return To_String (File_Principal (Auth.all).Token);
   end Authorize;

   overriding
   procedure Verify (Realm    : in out File_Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is
      Result : File_Principal_Access;
      Pos    : constant User_Maps.Cursor := Realm.Users.Find (Username);
   begin
      if not User_Maps.Has_Element (Pos) then
         Auth := null;
         return;
      end if;

      --  Verify that the crypt password with the recorded salt are the same.
      declare
         Expect : constant String := User_Maps.Element (Pos);
         Hash   : constant String := Realm.Crypt_Password (Expect, Password);
      begin
         if Hash /= Expect then
            Auth := null;
            return;
         end if;
      end;

      --  Generate a random token and make the principal to record it.
      declare
         Token : constant String := Realm.Random.Generate (Realm.Token_Bits);
      begin
         Result := new File_Principal;
         Ada.Strings.Unbounded.Append (Result.Token, Token);
         Ada.Strings.Unbounded.Append (Result.Name, Username);
         Realm.Tokens.Insert (Token, Result);
      end;
      Auth := Result.all'Access;
   end Verify;

   overriding
   procedure Verify (Realm : in out File_Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is
   begin
      null;
   end Verify;

   overriding
   procedure Revoke (Realm : in out File_Realm_Manager;
                     Auth  : in Principal_Access) is
   begin
      if Auth /= null and then Auth.all in File_Principal'Class then
         Realm.Tokens.Delete (To_String (File_Principal (Auth.all).Token));
      end if;
   end Revoke;

   --  ------------------------------
   --  Crypt the password using the given salt and return the string composed with
   --  the salt in clear text and the crypted password.
   --  ------------------------------
   function Crypt_Password (Realm    : in File_Realm_Manager;
                            Salt     : in String;
                            Password : in String) return String is
      Pos : Natural := Util.Strings.Index (Salt, ' ');
   begin
      if Pos = 0 then
         Pos := Salt'Last;
      else
         Pos := Pos - 1;
      end if;
      return Salt (Salt'First .. Pos) & " "
         & Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => Salt (Salt'First .. Pos),
                                                Data => Password,
                                                URL  => True);
   end Crypt_Password;

   --  ------------------------------
   --  Add a username with the associated password.
   --  ------------------------------
   procedure Add_User (Realm    : in out File_Realm_Manager;
                       Username : in String;
                       Password : in String) is
      Salt : constant String := Realm.Random.Generate (Realm.Token_Bits);
   begin
      Realm.Users.Include (Username, Realm.Crypt_Password (Salt, Password));
   end Add_User;

end Security.OAuth.File_Registry;

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

package body Security.OAuth.File_Registry is

   --  ------------------------------
   --  Get the principal name.
   --  ------------------------------
   overriding
   function Get_Name (From : in File_Principal) return String is
   begin
      return To_String (From.Name);
   end Get_Name;

   --  ------------------------------
   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   --  ------------------------------
   overriding
   function Find_Application (Realm     : in File_Application_Manager;
                              Client_Id : in String) return Servers.Application'Class is
      Pos : constant Application_Maps.Cursor := Realm.Applications.Find (Client_Id);
   begin
      if not Application_Maps.Has_Element (Pos) then
         raise Servers.Invalid_Application;
      end if;
      return Application_Maps.Element (Pos);
   end Find_Application;

   --  ------------------------------
   --  Add the application to the application repository.
   --  ------------------------------
   procedure Add_Application (Realm : in out File_Application_Manager;
                              App   : in Servers.Application) is
   begin
      Realm.Applications.Include (App.Get_Application_Identifier, App);
   end Add_Application;

   --  ------------------------------
   --  Authenticate the token and find the associated authentication principal.
   --  The access token has been verified and the token represents the identifier
   --  of the Tuple (client_id, user, session) that describes the authentication.
   --  The <tt>Authenticate</tt> procedure should look in its database (internal
   --  or external) to find the authentication principal that was granted for
   --  the token Tuple.  When the token was not found (because it was revoked),
   --  the procedure should return a null principal.  If the authentication
   --  principal can be cached, the <tt>Cacheable</tt> value should be set.
   --  In that case, the access token and authentication  principal are inserted
   --  in a cache.
   --  ------------------------------
   overriding
   procedure Authenticate (Realm     : in out File_Realm_Manager;
                           Token     : in String;
                           Auth      : out Principal_Access;
                           Cacheable : out Boolean) is
      Pos : constant Token_Maps.Cursor := Realm.Tokens.Find (Token);
   begin
      if Token_Maps.Has_Element (Pos) then
         Auth := Token_Maps.Element (Pos).all'Access;
      else
         Auth := null;
      end if;
      Cacheable := True;
   end Authenticate;

   --  ------------------------------
   --  Create an auth token string that identifies the given principal.  The returned
   --  token will be used by <tt>Authenticate</tt> to retrieve back the principal.  The
   --  returned token does not need to be signed.  It will be inserted in the public part
   --  of the returned access token.
   --  ------------------------------
   overriding
   function Authorize (Realm : in File_Realm_Manager;
                       App   : in Servers.Application'Class;
                       Scope : in String;
                       Auth  : in Principal_Access) return String is
   begin
      return To_String (File_Principal (Auth.all).Token);
   end Authorize;

   overriding
   procedure Verify (Realm    : in out File_Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access) is
      Result : File_Principal_Access;
      Pos    : constant User_Maps.Cursor := Realm.Users.Find (Username);
   begin
      if not User_Maps.Has_Element (Pos) then
         Auth := null;
         return;
      end if;

      --  Verify that the crypt password with the recorded salt are the same.
      declare
         Expect : constant String := User_Maps.Element (Pos);
         Hash   : constant String := Realm.Crypt_Password (Expect, Password);
      begin
         if Hash /= Expect then
            Auth := null;
            return;
         end if;
      end;

      --  Generate a random token and make the principal to record it.
      declare
         Token : constant String := Realm.Random.Generate (Realm.Token_Bits);
      begin
         Result := new File_Principal;
         Ada.Strings.Unbounded.Append (Result.Token, Token);
         Ada.Strings.Unbounded.Append (Result.Name, Username);
         Realm.Tokens.Insert (Token, Result);
      end;
      Auth := Result.all'Access;
   end Verify;

   overriding
   procedure Verify (Realm : in out File_Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access) is
   begin
      null;
   end Verify;

   overriding
   procedure Revoke (Realm : in out File_Realm_Manager;
                     Auth  : in Principal_Access) is
   begin
      if Auth /= null and then Auth.all in File_Principal'Class then
         Realm.Tokens.Delete (To_String (File_Principal (Auth.all).Token));
      end if;
   end Revoke;

   --  ------------------------------
   --  Crypt the password using the given salt and return the string composed with
   --  the salt in clear text and the crypted password.
   --  ------------------------------
   function Crypt_Password (Realm    : in File_Realm_Manager;
                            Salt     : in String;
                            Password : in String) return String is
      pragma Unreferenced (Realm);

      Pos : Natural := Util.Strings.Index (Salt, ' ');
   begin
      if Pos = 0 then
         Pos := Salt'Last;
      else
         Pos := Pos - 1;
      end if;
      return Salt (Salt'First .. Pos) & " "
         & Util.Encoders.HMAC.SHA1.Sign_Base64 (Key  => Salt (Salt'First .. Pos),
                                                Data => Password,
                                                URL  => True);
   end Crypt_Password;

   --  ------------------------------
   --  Add a username with the associated password.
   --  ------------------------------
   procedure Add_User (Realm    : in out File_Realm_Manager;
                       Username : in String;
                       Password : in String) is
      Salt : constant String := Realm.Random.Generate (Realm.Token_Bits);
   begin
      Realm.Users.Include (Username, Realm.Crypt_Password (Salt, Password));
   end Add_User;

end Security.OAuth.File_Registry;

Fix compilation warning for Crypt_Password