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

with Ada.Task_Attributes;
with Ada.Unchecked_Deallocation;

package body Security.Contexts is

   use type Security.Policies.Policy_Context_Array_Access;
   use type Security.Policies.Policy_Access;
   use type Security.Policies.Policy_Context_Access;

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

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context'Class,
                                      Name   => Security.Policies.Policy_Context_Access);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         return null;
      else
         return Context.Manager.Get_Policy (Name);
      end if;
   end Get_Policy;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         Perm : Security.Permissions.Permission (Permission);
      begin
         Result := Context.Manager.Has_Permission (Context, Perm);
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context_Array,
                                        Name   => Security.Policies.Policy_Context_Array_Access);
   begin
      Task_Context.Set_Value (Context.Previous);
      if Context.Contexts /= null then
         for I in Context.Contexts'Range loop
            Free (Context.Contexts (I));
         end loop;
         Free (Context.Contexts);
      end if;
   end Finalize;

   --  ------------------------------
   --  Set a policy context information represented by Value and associated with
   --  the policy index Policy.
   --  ------------------------------
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access) is
   begin
      if Context.Contexts = null then
         Context.Contexts := Context.Manager.Create_Policy_Contexts;
      end if;
      Free (Context.Contexts (Policy.Get_Policy_Index));
      Context.Contexts (Policy.Get_Policy_Index) := Value;
   end Set_Policy_Context;

   --  ------------------------------
   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   --  ------------------------------
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access is
      Result : Security.Policies.Policy_Context_Access;
   begin
      if Policy = null then
         raise Invalid_Policy;
      end if;
      if Context.Contexts = null then
         raise Invalid_Context;
      end if;
      Result := Context.Contexts (Policy.Get_Policy_Index);
      return Result;
   end Get_Policy_Context;

   --  ------------------------------
   --  Returns True if a context information was registered for the security policy.
   --  ------------------------------
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean is
   begin
      return Policy /= null and then Context.Contexts /= null
        and then Context.Contexts (Policy.Get_Policy_Index) /= null;
   end Has_Policy_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

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

with Ada.Task_Attributes;
with Ada.Unchecked_Deallocation;

package body Security.Contexts is

   use type Security.Policies.Policy_Context_Array_Access;
   use type Security.Policies.Policy_Access;
   use type Security.Policies.Policy_Context_Access;

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

   procedure Free is
      new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context'Class,
                                      Name   => Security.Policies.Policy_Context_Access);

   --  ------------------------------
   --  Get the application associated with the current service operation.
   --  ------------------------------
   function Get_User_Principal (Context : in Security_Context'Class)
                                return Security.Principal_Access is
   begin
      return Context.Principal;
   end Get_User_Principal;

   --  ------------------------------
   --  Get the permission manager.
   --  ------------------------------
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access is
   begin
      return Context.Manager;
   end Get_Permission_Manager;

   --  ------------------------------
   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   --  ------------------------------
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         return null;
      else
         return Context.Manager.Get_Policy (Name);
      end if;
   end Get_Policy;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean) is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      declare
         Perm : Security.Permissions.Permission (Permission);
      begin
         Result := Context.Manager.Has_Permission (Context, Perm);
      end;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean) is
      Index : constant Permissions.Permission_Index
        := Permissions.Get_Permission_Index (Permission);
   begin
      Security_Context'Class (Context).Has_Permission (Index, Result);
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission'Class;
                             Result     : out Boolean) is
      use type Security.Policies.Policy_Manager_Access;
   begin
      if Context.Manager = null then
         Result := False;
         return;
      end if;
      Result := Context.Manager.Has_Permission (Context, Permission);
   end Has_Permission;

   --  ------------------------------
   --  Initializes the service context.  By creating the Security_Context variable,
   --  the instance will be associated with the current task attribute.  If the current task
   --  already has a security context, the new security context is installed, the old one
   --  being kept.
   --  ------------------------------
   overriding
   procedure Initialize (Context : in out Security_Context) is
   begin
      Context.Previous := Task_Context.Value;
      Task_Context.Set_Value (Context'Unchecked_Access);
   end Initialize;

   --  ------------------------------
   --  Finalize the security context releases any object.  The previous security context is
   --  restored to the current task attribute.
   --  ------------------------------
   overriding
   procedure Finalize (Context : in out Security_Context) is

      procedure Free is
        new Ada.Unchecked_Deallocation (Object => Security.Policies.Policy_Context_Array,
                                        Name   => Security.Policies.Policy_Context_Array_Access);
   begin
      Task_Context.Set_Value (Context.Previous);
      if Context.Contexts /= null then
         for I in Context.Contexts'Range loop
            Free (Context.Contexts (I));
         end loop;
         Free (Context.Contexts);
      end if;
   end Finalize;

   --  ------------------------------
   --  Set a policy context information represented by Value and associated with
   --  the policy index Policy.
   --  ------------------------------
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access) is
   begin
      if Context.Contexts = null then
         Context.Contexts := Context.Manager.Create_Policy_Contexts;
      end if;
      Free (Context.Contexts (Policy.Get_Policy_Index));
      Context.Contexts (Policy.Get_Policy_Index) := Value;
   end Set_Policy_Context;

   --  ------------------------------
   --  Get the policy context information registered for the given security policy in the security
   --  context Context.
   --  Raises Invalid_Context if there is no such information.
   --  Raises Invalid_Policy if the policy was not set.
   --  ------------------------------
   function Get_Policy_Context (Context  : in Security_Context;
                                Policy   : in Security.Policies.Policy_Access)
                                return Security.Policies.Policy_Context_Access is
      Result : Security.Policies.Policy_Context_Access;
   begin
      if Policy = null then
         raise Invalid_Policy;
      end if;
      if Context.Contexts = null then
         raise Invalid_Context;
      end if;
      Result := Context.Contexts (Policy.Get_Policy_Index);
      return Result;
   end Get_Policy_Context;

   --  ------------------------------
   --  Returns True if a context information was registered for the security policy.
   --  ------------------------------
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean is
   begin
      return Policy /= null and then Context.Contexts /= null
        and then Context.Contexts (Policy.Get_Policy_Index) /= null;
   end Has_Policy_Context;

   --  ------------------------------
   --  Set the current application and user context.
   --  ------------------------------
   procedure Set_Context (Context   : in out Security_Context;
                          Manager   : in Security.Policies.Policy_Manager_Access;
                          Principal : in Security.Principal_Access) is
   begin
      Context.Manager   := Manager;
      Context.Principal := Principal;
   end Set_Context;

   --  ------------------------------
   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   --  ------------------------------
   function Current return Security_Context_Access is
   begin
      return Task_Context.Value;
   end Current;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in Permissions.Permission_Index) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

   --  ------------------------------
   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   --  ------------------------------
   function Has_Permission (Permission : in String) return Boolean is
      Result  : Boolean;
      Context : constant Security_Context_Access := Current;
   begin
      if Context = null then
         return False;
      else
         Context.Has_Permission (Permission, Result);
         return Result;
      end if;
   end Has_Permission;

end Security.Contexts;

Implement the new Has_Permission procedure


-----------------------------------------------------------------------
--  ado-c -- Support for driver implementation
--  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.
-----------------------------------------------------------------------

package body ADO.C is

   use Ada.Strings.Unbounded;
   use type Interfaces.C.Strings.chars_ptr;

   --  ------------------------------
   --  Convert a string to a C string.
   --  ------------------------------
   function To_String_Ptr (S : String) return String_Ptr is
   begin
      return Result : String_Ptr do
         Result.Ptr := Strings.New_String (S);
      end return;
   end To_String_Ptr;

   --  ------------------------------
   --  Convert an unbounded string to a C string.
   --  ------------------------------
   function To_String_Ptr (S : Ada.Strings.Unbounded.Unbounded_String) return String_Ptr is
   begin
      return Result : String_Ptr do
         Result.Ptr := Strings.New_String (To_String (S));
      end return;
   end To_String_Ptr;

   --  ------------------------------
   --  Get the C string pointer.
   --  ------------------------------
   function To_C (S : String_Ptr) return Interfaces.C.Strings.chars_ptr is
   begin
      return S.Ptr;
   end To_C;

   --  ------------------------------
   --  Set the string
   --  ------------------------------
   procedure Set_String (S     : in out String_Ptr;
                         Value : in String) is
   begin
      if S.Ptr /= Interfaces.C.Strings.Null_Ptr then
         Strings.Free (S.Ptr);
      end if;
      S.Ptr := Strings.New_String (Value);
   end Set_String;

   --  ------------------------------
   --  Reclaim the storage held by the C string.
   --  ------------------------------
   procedure Finalize (S : in out String_Ptr) is
   begin
      Strings.Free (S.Ptr);
   end Finalize;

end ADO.C;

-----------------------------------------------------------------------
--  ado-c -- Support for driver implementation
--  Copyright (C) 2009, 2010, 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.
-----------------------------------------------------------------------

package body ADO.C is

   use Ada.Strings.Unbounded;
   use type Interfaces.C.Strings.chars_ptr;

   --  ------------------------------
   --  Convert a string to a C string.
   --  ------------------------------
   function To_String_Ptr (S : String) return String_Ptr is
   begin
      return Result : String_Ptr do
         Result.Ptr := Strings.New_String (S);
      end return;
   end To_String_Ptr;

   --  ------------------------------
   --  Get the C string pointer.
   --  ------------------------------
   function To_C (S : String_Ptr) return Interfaces.C.Strings.chars_ptr is
   begin
      return S.Ptr;
   end To_C;

   --  ------------------------------
   --  Set the string
   --  ------------------------------
   procedure Set_String (S     : in out String_Ptr;
                         Value : in String) is
   begin
      if S.Ptr /= Interfaces.C.Strings.Null_Ptr then
         Strings.Free (S.Ptr);
      end if;
      S.Ptr := Strings.New_String (Value);
   end Set_String;

   --  ------------------------------
   --  Reclaim the storage held by the C string.
   --  ------------------------------
   procedure Finalize (S : in out String_Ptr) is
   begin
      Strings.Free (S.Ptr);
   end Finalize;

end ADO.C;

Remove unused To_String_Ptr operation

Remove unused To_String_Ptr operation


-----------------------------------------------------------------------
--  awa-storages-tests -- Unit tests for storages module
--  Copyright (C) 2020 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.Tests;
with AWA.Tests;
with Servlet.requests.Mockup;
with Servlet.Responses.Mockup;
with Ada.Strings.Unbounded;

package AWA.Storages.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new AWA.Tests.Test with record
      Folder_Ident  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the wiki page as anonymous users.
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String);

   --  Verify that the wiki lists contain the given page.
   procedure Verify_List_Contains (T    : in out Test;
                                   Page : in String);

   --  Test access to the wiki as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of document by simulating web requests.
   procedure Test_Create_Document (T : in out Test);

   --  Test getting a document which does not exist.
   procedure Test_Missing_Document (T : in out Test);

end AWA.Storages.Tests;

-----------------------------------------------------------------------
--  awa-storages-tests -- Unit tests for storages module
--  Copyright (C) 2020 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.Tests;
with AWA.Tests;

package AWA.Storages.Tests is

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite);

   type Test is new AWA.Tests.Test with record
      Folder_Ident  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   --  Get some access on the wiki page as anonymous users.
   procedure Verify_Anonymous (T     : in out Test;
                               Page  : in String;
                               Title : in String);

   --  Verify that the wiki lists contain the given page.
   procedure Verify_List_Contains (T    : in out Test;
                                   Page : in String);

   --  Test access to the wiki as anonymous user.
   procedure Test_Anonymous_Access (T : in out Test);

   --  Test creation of document by simulating web requests.
   procedure Test_Create_Document (T : in out Test);

   --  Test getting a document which does not exist.
   procedure Test_Missing_Document (T : in out Test);

end AWA.Storages.Tests;

Remove unused with clauses

Remove unused with clauses


-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 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.Exceptions;
with AUnit;
with AUnit.Test_Caller;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Tests");

   package Caller is new AUnit.Test_Caller (Test);

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               Assert (T, Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                       & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Load", Test_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save", Test_Create_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Master_Connection init error", Test_Not_Open'Access));
      Suite.Add_Test (Caller.Create ("Test Sequences.Factory", Test_Allocate'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save/Create/Update",
        Test_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Create (DB Insert)",
        Test_Perf_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Statement.Delete_Statement (delete all)",
        Test_Delete_All'Access));
   end Add_Tests;

end ADO.Tests;

-----------------------------------------------------------------------
--  ADO Sequences -- Database sequence generator
--  Copyright (C) 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.Exceptions;
with AUnit;
with AUnit.Test_Caller;

with ADO.Statements;
with ADO.Objects;
with ADO.Sessions;
with Regtests;

with Regtests.Simple.Model;
with Util.Measures;
with Util.Log;
with Util.Log.Loggers;

package body ADO.Tests is

   use Util.Log;
   use Ada.Exceptions;
   use ADO.Statements;
   use type Regtests.Simple.Model.User_Ref;
   use type Regtests.Simple.Model.Allocate_Ref;

   Log : constant Loggers.Logger := Loggers.Create ("ADO.Tests");

   package Caller is new AUnit.Test_Caller (Test);

   procedure Fail (T : in Test; Message : in String);
   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence);

   procedure Fail (T : in Test; Message : in String) is
   begin
      T.Assert (False, Message);
   end Fail;

   procedure Assert_Has_Message (T : in Test;
                                 E : in Exception_Occurrence) is
      Message : constant String := Exception_Message (E);
   begin
      Log.Info ("Exception: {0}", Message);
      T.Assert (Message'Length > 0,
                "Exception " & Exception_Name (E) & " does not have any message");
   end Assert_Has_Message;

   procedure Set_Up (T : in out Test) is
   begin
      null;
   end Set_Up;

   --  ------------------------------
   --  Check:
   --     Object_Ref.Load
   --     Object_Ref.Is_Null
   --  ------------------------------
   procedure Test_Load (T : in out Test) is

      DB  : ADO.Sessions.Session := Regtests.Get_Database;

      Object : Regtests.Simple.Model.User_Ref;
   begin
      T.Assert (Object.Is_Null, "Object_Ref.Is_Null: Empty object must be null");

      Object.Load (DB, -1);
      T.Assert (False, "Object_Ref.Load: Load must raise NOT_FOUND exception");

   exception
      when ADO.Objects.NOT_FOUND =>
         T.Assert (Object.Is_Null, "Object_Ref.Load: Must not change the object");
   end Test_Load;

   --  ------------------------------
   --  Check:
   --    Object_Ref.Load
   --    Object_Ref.Save
   --    <Model>.Set_xxx (Unbounded_String)
   --    <Model>.Create
   --  ------------------------------
   procedure Test_Create_Load (T : in out Test) is

      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Object : Regtests.Simple.Model.User_Ref;
      Check  : Regtests.Simple.Model.User_Ref;
   begin
      --  Initialize and save an object
      Object.Set_Name ("A simple test name");
      Object.Save (DB);

      T.Assert (Object.Get_Id > 0, "Saving an object did not allocate an identifier");

      --  Load the object
      Check.Load (DB, Object.Get_Id);
      T.Assert (not Check.Is_Null, "Object_Ref.Load: Loading the object failed");
   end Test_Create_Load;

   --  ------------------------------
   --  Check:
   --    Various error checks on database connections
   --
   --    Master_Connection.Rollback
   --  ------------------------------
   procedure Test_Not_Open (T : in out Test) is
      DB : ADO.Sessions.Master_Session;
   begin
      begin
         DB.Rollback;
         Fail (T, "Master_Connection.Rollback should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

      begin
         DB.Commit;
         Fail (T, "Master_Connection.Commit should raise an exception");

      exception
         when E : ADO.Sessions.NOT_OPEN =>
            Assert_Has_Message (T, E);
      end;

   end Test_Not_Open;

   --  ------------------------------
   --  Check id generation
   --  ------------------------------
   procedure Test_Allocate (T : in out Test) is
      DB     : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Key    : ADO.Objects.Object_Key (Of_Type => ADO.Objects.KEY_INTEGER,
                                       Of_Class => Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      PrevId : Identifier := NO_IDENTIFIER;
      S      : Util.Measures.Stamp;
   begin
      for I in 1 .. 200 loop
         declare
            Obj : Regtests.Simple.Model.Allocate_Ref;
         begin
            Obj.Save (DB);
            Key := Obj.Get_Key;
            if PrevId /= NO_IDENTIFIER then
               T.Assert (Objects.Get_Value (Key) = PrevId + 1, "Invalid allocated identifier: "
                         & Objects.To_String (Key) & " previous=" & Identifier'Image (PrevId));
            end if;
            PrevId := Objects.Get_Value (Key);
         end;
      end loop;
      Util.Measures.Report (S, "Allocate 200 ids");
   end Test_Allocate;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --    Object.Find
   --    Object.Save (update)
   --  ------------------------------
   procedure Test_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB   : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      Ref  : Regtests.Simple.Model.Allocate_Ref;
      Ref2 : Regtests.Simple.Model.Allocate_Ref;
   begin
      Ref.Set_Name ("Testing the allocation");
      Ref.Save (DB);
      T.Assert (Ref.Get_Id > 0, "Object must have an id");

      Ref.Set_Name ("Testing the allocation: update");
      Ref.Save (DB);

      Ref2.Load (DB, Ref.Get_Id);

   end Test_Create_Save;

   --  ------------------------------
   --  Check:
   --    Object.Save (with creation)
   --  ------------------------------
   procedure Test_Perf_Create_Save (T : in out Test) is
      use ADO.Objects;

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;

      S  : Util.Measures.Stamp;
   begin
      DB.Begin_Transaction;
      for I in 1 .. 1_000 loop
         declare
            Ref  : Regtests.Simple.Model.Allocate_Ref;
         begin
            Ref.Set_Name ("Testing the allocation");
            Ref.Save (DB);
            T.Assert (Ref.Get_Id > 0, "Object must have an id");
         end;
      end loop;
      DB.Commit;
      Util.Measures.Report (S, "Create 1000 rows");
   end Test_Perf_Create_Save;

   procedure Test_Delete_All (T : in out Test) is

      DB : ADO.Sessions.Master_Session := Regtests.Get_Master_Database;
      Stmt : ADO.Statements.Delete_Statement
        := DB.Create_Statement (Regtests.Simple.Model.ALLOCATE_TABLE'Access);
      Result : Natural;
   begin
      DB.Begin_Transaction;
      Stmt.Execute (Result);
      Log.Info ("Deleted {0} rows", Natural'Image (Result));
      DB.Commit;

      T.Assert (Result > 100, "Too few rows were deleted");
   end Test_Delete_All;

   procedure Add_Tests (Suite : AUnit.Test_Suites.Access_Test_Suite) is
   begin
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Load", Test_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save", Test_Create_Load'Access));
      Suite.Add_Test (Caller.Create ("Test Master_Connection init error", Test_Not_Open'Access));
      Suite.Add_Test (Caller.Create ("Test Sequences.Factory", Test_Allocate'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Save/Create/Update",
        Test_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Object_Ref.Create (DB Insert)",
        Test_Perf_Create_Save'Access));
      Suite.Add_Test (Caller.Create ("Test Statement.Delete_Statement (delete all)",
        Test_Delete_All'Access));
   end Add_Tests;

end ADO.Tests;

Fix compilation with GNAT 2011

Fix compilation with GNAT 2011


-- Copyright 2017-2021 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

local json = require("json")

name = "Spyse"
type = "api"

function start()
    setratelimit(1)
end

function check()
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c ~= nil and c.key ~= nil and c.key ~= "") then
        return true
    end
    return false
end

function vertical(ctx, domain)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end

    for i = 0,10000,100 do
        local u = subsurl(domain, i)

        local resp = getpage(ctx, u, c.key, cfg.ttl)
        if (resp == "") then
            break
        end

        local d = json.decode(resp)
        if (d == nil or #(d['data'].items) == 0) then
            return false
        end

        for i, item in pairs(d['data'].items) do
            sendnames(ctx, item.name)
        end
    end
end

function subsurl(domain, offset)
    return "https://api.spyse.com/v3/data/domain/subdomain?domain=" .. domain .. "&limit=100&offset=" .. tostring(offset)
end

function horizontal(ctx, domain)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end

    -- Spyse API domain/related/domain often returns false positives (domains not owned by the provided domain)
    --horizonnames(ctx, domain, c.key, cfg.ttl)
    horizoncerts(ctx, domain, c.key, cfg.ttl)
end

function horizonnames(ctx, domain, key, ttl)
    for i = 0,10000,100 do
        u = namesurl(domain, i)

        resp = getpage(ctx, u, key, ttl)
        if (resp == "") then
            break
        end

        local d = json.decode(resp)
        if (d == nil or #(d['data'].items) == 0) then
            break
        end

        for i, item in pairs(d['data'].items) do
            if (item.domain.name ~= "") then
                local names = find(item.domain.name, subdomainre)

                if (names ~= nil and #names > 0 and names[1] ~= "") then
                    associated(ctx, domain, names[1])
                end
            end
        end
    end
end

function namesurl(domain, offset)
    return "https://api.spyse.com/v3/data/domain/related/domain?domain=" .. domain .. "&limit=100&offset=" .. tostring(offset)
end

function horizoncerts(ctx, domain, key, ttl)
    local u = "https://api.spyse.com/v3/data/domain/org?domain=" .. domain
    local resp = getpage(ctx, u, key, ttl)
    if (resp == "") then
        return
    end

    local d = json.decode(resp)
    if (d == nil or d['data'].id == nil) then
        return
    end
    local orgid = d['data'].id

    for i = 0,10000,100 do
        u = certsurl(orgid, i)

        resp = getpage(ctx, u, key, ttl)
        if (resp == "") then
            break
        end

        local d = json.decode(resp)
        if (d == nil or #(d['data'].items) == 0) then
            break
        end

        for i, item in pairs(d['data'].items) do
            local san = item.parsed.extensions.subject_alt_name

            if (san ~= nil and #(san.dns_names) > 0) then
                for j, name in pairs(san.dns_names) do
                    local names = find(name, subdomainre)

                    if (names ~= nil and #names > 0 and names[1] ~= "") then
                        associated(ctx, domain, names[1])
                    end
                end
            end
        end
    end
end

function certsurl(id, offset)
    return "https://api.spyse.com/v3/data/org/cert/subject?id=" .. id .. "&limit=100&offset=" .. tostring(offset)
end

function asn(ctx, addr, asn)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end

    local prefix
    if (asn == 0) then
        if (addr == "") then
            return
        end

        asn, prefix = getasn(ctx, addr, c.key, cfg.ttl)
        if (asn == 0) then
            return
        end
    end

    local a = asinfo(ctx, asn, c.key, cfg.ttl)
    if (a == nil or #(a.netblocks) == 0) then
        return
    end

    if (prefix == "") then
        prefix = a.netblocks[1]
        parts = split(prefix, "/")
        addr = parts[1]
    end

    newasn(ctx, {
        ['addr']=addr,
        ['asn']=asn,
        ['prefix']=prefix,
        ['desc']=a.desc,
        ['netblocks']=a.netblocks,
    })
end

function getasn(ctx, ip, key, ttl)
    local u = "https://api.spyse.com/v3/data/ip?ip=" .. tostring(ip)

    local resp = getpage(ctx, u, key, ttl)
    if (resp == "") then
        return 0, ""
    end

    local d = json.decode(resp)
    if (d == nil or #(d['data'].items) == 0) then
        return 0, ""
    end

    local cidr
    local asn = 0
    for i, item in pairs(d['data'].items) do
        local num = item.isp_info.as_num

        if (asn == 0 or asn < num) then
            asn = num
            cidr = item.cidr
        end
    end

    return asn, cidr
end

function asinfo(ctx, asn, key, ttl)
    local u = "https://api.spyse.com/v3/data/as?asn=" .. tostring(asn)

    local resp = getpage(ctx, u, key, ttl)
    if (resp == "") then
        return nil
    end

    local d = json.decode(resp)
    if (d == nil or #(d['data'].items) == 0) then
        return nil
    end

    local cidrs = {}
    for i, p in pairs(d.items[1].ipv4_cidr_array) do
        table.insert(cidrs, p.ip .. "/" .. tostring(p.cidr))
    end
    for i, p in pairs(d.items[1].ipv6_cidr_array) do
        table.insert(cidrs, p.ip .. "/" .. tostring(p.cidr))
    end

    return {
        desc=d.items[1].as_org,
        netblocks=cidrs,
    }
end

function getpage(ctx, url, key, ttl)
    local resp, err = request(ctx, {
        ['url']=url,
        headers={
            ['Authorization']="Bearer " .. key,
            ['Content-Type']="application/json",
        },
    })
    if (err ~= nil and err ~= "") then
        return ""
    end

    return resp
end

function sendnames(ctx, content)
    local names = find(content, subdomainre)
    if (names == nil) then
        return
    end

    local found = {}
    for i, v in pairs(names) do
        if (found[v] == nil) then
            newname(ctx, v)
            found[v] = true
        end
    end
end

function split(str, delim)
    local result = {}
    local pattern = "[^%" .. delim .. "]+"

    local matches = find(str, pattern)
    if (matches == nil or #matches == 0) then
        return result
    end

    for i, match in pairs(matches) do
        table.insert(result, match)
    end

    return result
end

-- Copyright 2017-2021 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

local json = require("json")

name = "Spyse"
type = "api"

function start()
    setratelimit(1)
end

function check()
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c ~= nil and c.key ~= nil and c.key ~= "") then
        return true
    end
    return false
end

function vertical(ctx, domain)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end
    local step = 100
    for i = 0,10000,step do
        local payload = '{"search_params":[{"name":{"operator":"ends","value":".' .. domain .. '"}}],"limit":100,"offset":' .. tostring(i) .. '}'
        local resp = postreq(ctx, "https://api.spyse.com/v4/data/domain/search", c.key, cfg.ttl, payload)

        if (resp == "") then
            break
        end

        local d = json.decode(resp)
        if (d == nil or #(d['data'].items) == 0) then
            return false
        end

        for i, item in pairs(d['data'].items) do
            sendnames(ctx, item.name)
        end
        if (i+step >= d['data'].total_items) then
            break
        end
    end
end

function horizontal(ctx, domain)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end

    horizoncerts(ctx, domain, c.key, cfg.ttl)
end

function horizoncerts(ctx, domain, key, ttl)
    local u = "https://api.spyse.com/v4/data/domain/" .. domain
    local resp = getpage(ctx, u, key, ttl)
    if (resp == "") then
        return
    end
    local d = json.decode(resp)
    if (d == nil or #(d['data'].items) == 0) then
        return
    end
    if (d['data'].items[0].cert_summary == nil) then
        return
    end

    local certid = d['data'].items[0].cert_summary.fingerprint_sha256

    u = "https://api.spyse.com/v4/data/certificate/" .. certid
    resp = getpage(ctx, u, key, ttl)

    if (resp == "") then
        return
    end

    d = json.decode(resp)
    if (d == nil or #(d['data'].items) == 0) then
        return
    end

    local san = d['data'].items[0].parsed.extensions.subject_alt_name

    if (san ~= nil and #(san.dns_names) > 0) then
        for j, name in pairs(san.dns_names) do
            local names = find(name, subdomainre)
            if (names ~= nil and #names > 0 and names[1] ~= "") then
                associated(ctx, domain, names[1])
            end
        end
    end
end

function asn(ctx, addr, asn)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end

    local prefix
    if (asn == 0) then
        if (addr == "") then
            return
        end

        asn, prefix = getasn(ctx, addr, c.key, cfg.ttl)
        if (asn == 0) then
            return
        end
    end

    local a = asinfo(ctx, asn, c.key, cfg.ttl)
    if (a == nil or #(a.netblocks) == 0) then
        return
    end

    if (prefix == "") then
        prefix = a.netblocks[1]
        parts = split(prefix, "/")
        addr = parts[1]
    end

    newasn(ctx, {
        ['addr']=addr,
        ['asn']=asn,
        ['prefix']=prefix,
        ['desc']=a.desc,
        ['netblocks']=a.netblocks,
    })
end

function getasn(ctx, ip, key, ttl)
    local u = "https://api.spyse.com/v4/data/ip/" .. tostring(ip)

    local resp = getpage(ctx, u, key, ttl)
    if (resp == "") then
        return 0, ""
    end

    local d = json.decode(resp)
    if (d == nil or #(d['data'].items) == 0) then
        return 0, ""
    end

    local cidr
    local asn = 0
    for i, item in pairs(d['data'].items) do
        local num = item.isp_info.as_num

        if (asn == 0 or asn < num) then
            asn = num
            cidr = item.cidr
        end
    end

    return asn, cidr
end

function asinfo(ctx, asn, key, ttl)
    local u = "https://api.spyse.com/v4/data/as/" .. tostring(asn)

    local resp = getpage(ctx, u, key, ttl)
    if (resp == "") then
        return nil
    end

    local d = json.decode(resp)
    if (d == nil or #(d['data'].items) == 0) then
        return nil
    end

    local cidrs = {}
    for i, p in pairs(d.items[1].ipv4_cidr_array) do
        table.insert(cidrs, p.ip .. "/" .. tostring(p.cidr))
    end
    for i, p in pairs(d.items[1].ipv6_cidr_array) do
        table.insert(cidrs, p.ip .. "/" .. tostring(p.cidr))
    end

    return {
        desc=d.items[1].as_org,
        netblocks=cidrs,
    }
end

function getpage(ctx, url, key, ttl)
    local resp, err = request(ctx, {
        ['url']=url,
        headers={
            ['Authorization']="Bearer " .. key,
            ['Content-Type']="application/json",
        },
    })
    if (err ~= nil and err ~= "") then
        return ""
    end

    return resp
end

function postreq(ctx, url, key, ttl, payload)
    local resp, err = request(ctx, {
        ['url']=url,
        method="POST",
        data=payload,
        headers={
            ['Authorization']="Bearer " .. key,
            ['Content-Type']="application/json",
        },
    })
    if (err ~= nil and err ~= "") then
        return ""
    end

    return resp
end

function sendnames(ctx, content)
    local names = find(content, subdomainre)
    if (names == nil) then
        return
    end

    local found = {}
    for i, v in pairs(names) do
        if (found[v] == nil) then
            newname(ctx, v)
            found[v] = true
        end
    end
end

function split(str, delim)
    local result = {}
    local pattern = "[^%" .. delim .. "]+"

    local matches = find(str, pattern)
    if (matches == nil or #matches == 0) then
        return result
    end

    for i, match in pairs(matches) do
        table.insert(result, match)
    end

    return result
end

update spyse api script

improvement: update spyse api script


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

with Util.Test_Caller;

with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

with ASF.Applications.Tests;
with ASF.Applications.Main.Configs;
with ASF.Requests.Mockup;
package body ASF.Applications.Main.Tests is

   use Util.Tests;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access;

   package Caller is new Util.Test_Caller (Test, "Applications.Main");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Read_Configuration",
                       Test_Read_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Load_Bundle",
                       Test_Load_Bundle'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register,Load_Bundle",
                       Test_Bundle_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Get_Supported_Locales",
                       Test_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      T.App := new ASF.Applications.Main.Application;
      C.Copy (Util.Tests.Get_Properties);
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Applications.Main.Application'Class,
                                        Name   => ASF.Applications.Main.Application_Access);
   begin
      Free (T.App);
   end Tear_Down;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Applications.Tests.Form_Bean_Access := new Applications.Tests.Form_Bean;
   begin
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Read_Configuration (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("config/empty.xml");
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

   end Test_Read_Configuration;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      Path : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-module.xml");

   begin
      T.App.Register_Class ("ASF.Applications.Tests.Form_Bean", Create_Form_Bean'Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Bean;

   --  ------------------------------
   --  Test loading a resource bundle through the application.
   --  ------------------------------
   procedure Test_Load_Bundle (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Bundle : ASF.Locales.Bundle;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Load_Bundle (Name   => "samples",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Equals (T, "Help", String '(Bundle.Get ("layout_help_label")),
                                "Invalid bundle value");

      T.App.Load_Bundle (Name   => "asf",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Matches (T, ".*greater than.*",
                                 String '(Bundle.Get ("validators.length.maximum")),
                                "Invalid bundle value");
   end Test_Load_Bundle;

   --  ------------------------------
   --  Test application configuration and registration of resource bundles.
   --  ------------------------------
   procedure Test_Bundle_Configuration (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Result : Util.Beans.Basic.Readonly_Bean_Access;
      Ctx    : EL.Contexts.Default.Default_Context;
      Scope  : Scope_Type;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("samplesMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The samplesMsg bundle was not created");

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("defaultMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The defaultMsg bundle was not created");
   end Test_Bundle_Configuration;

   --  ------------------------------
   --  Test locales.
   --  ------------------------------
   procedure Test_Locales (T : in out Test) is
      use Util.Locales;

      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-locales.xml");
      Req       : aliased ASF.Requests.Mockup.Request;
      View      : constant access Applications.Views.View_Handler'Class := T.App.Get_View_Handler;
      Context   : aliased ASF.Contexts.Faces.Faces_Context;
      ELContext : aliased EL.Contexts.Default.Default_Context;
      Locale    : Util.Locales.Locale;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (T.App.Get_Default_Locale),
                                "Invalid default locale");

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Request (Req'Unchecked_Access);
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.3, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, en-gb, en;q=0.8, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.ENGLISH),
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, ru, it;q=0.8, de;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");
   end Test_Locales;

end ASF.Applications.Main.Tests;

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

with Util.Test_Caller;

with Util.Beans.Objects;

with Ada.Unchecked_Deallocation;

with EL.Contexts.Default;

with ASF.Applications.Tests;
with ASF.Applications.Main.Configs;
with ASF.Requests.Mockup;
package body ASF.Applications.Main.Tests is

   use Util.Tests;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access;

   package Caller is new Util.Test_Caller (Test, "Applications.Main");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Read_Configuration",
                       Test_Read_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Create",
                       Test_Create_Bean'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Load_Bundle",
                       Test_Load_Bundle'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Register,Load_Bundle",
                       Test_Bundle_Configuration'Access);
      Caller.Add_Test (Suite, "Test ASF.Applications.Main.Get_Supported_Locales",
                       Test_Locales'Access);
   end Add_Tests;

   --  ------------------------------
   --  Initialize the test application
   --  ------------------------------
   procedure Set_Up (T : in out Test) is
      Fact : ASF.Applications.Main.Application_Factory;
      C    : ASF.Applications.Config;
   begin
      T.App := new ASF.Applications.Main.Application;
      C.Copy (Util.Tests.Get_Properties);
      T.App.Initialize (C, Fact);
      T.App.Register ("layoutMsg", "layout");
   end Set_Up;

   --  ------------------------------
   --  Deletes the application object
   --  ------------------------------
   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
        new Ada.Unchecked_Deallocation (Object => ASF.Applications.Main.Application'Class,
                                        Name   => ASF.Applications.Main.Application_Access);
   begin
      Free (T.App);
   end Tear_Down;

   function Create_Form_Bean return Util.Beans.Basic.Readonly_Bean_Access is
      Result : constant Applications.Tests.Form_Bean_Access := new Applications.Tests.Form_Bean;
   begin
      return Result.all'Access;
   end Create_Form_Bean;

   --  ------------------------------
   --  Test creation of module
   --  ------------------------------
   procedure Test_Read_Configuration (T : in out Test) is
      Path : constant String := Util.Tests.Get_Test_Path ("config/empty.xml");
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

   end Test_Read_Configuration;

   --  ------------------------------
   --  Test creation of a module and registration in an application.
   --  ------------------------------
   procedure Test_Create_Bean (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type);

      procedure Check (Name : in String;
                       Kind : in ASF.Beans.Scope_Type) is
         Value : Util.Beans.Objects.Object;
         Bean  : Util.Beans.Basic.Readonly_Bean_Access;
         Scope : ASF.Beans.Scope_Type;
         Context : EL.Contexts.Default.Default_Context;
      begin
         T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String (Name),
                       Context => Context,
                       Result  => Bean,
                       Scope   => Scope);
         T.Assert (Kind = Scope, "Invalid scope for " & Name);
         T.Assert (Bean /= null, "Invalid bean object");
         Value := Util.Beans.Objects.To_Object (Bean);
         T.Assert (not Util.Beans.Objects.Is_Null (Value), "Invalid bean");

         --  Special test for the sessionForm bean which is initialized by configuration properties
         if Name = "sessionForm" then
            T.Assert_Equals ("John.Rambo@gmail.com",
                             Util.Beans.Objects.To_String (Bean.Get_Value ("email")),
                             "Session form not initialized");
         end if;
      end Check;

      Path : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-module.xml");

   begin
      T.App.Register_Class ("ASF.Applications.Tests.Form_Bean", Create_Form_Bean'Access);
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      --  Check the 'regtests/config/test-module.xml' managed bean configuration.
      Check ("applicationForm", ASF.Beans.APPLICATION_SCOPE);
      Check ("sessionForm", ASF.Beans.SESSION_SCOPE);
      Check ("requestForm", ASF.Beans.REQUEST_SCOPE);
   end Test_Create_Bean;

   --  ------------------------------
   --  Test loading a resource bundle through the application.
   --  ------------------------------
   procedure Test_Load_Bundle (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Bundle : ASF.Locales.Bundle;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Load_Bundle (Name   => "samples",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Equals (T, "Help", String '(Bundle.Get ("layout_help_label")),
                                "Invalid bundle value");

      T.App.Load_Bundle (Name   => "asf",
                         Locale => "en",
                         Bundle => Bundle);
      Util.Tests.Assert_Matches (T, ".*greater than.*",
                                 String '(Bundle.Get ("validators.length.maximum")),
                                "Invalid bundle value");
   end Test_Load_Bundle;

   --  ------------------------------
   --  Test application configuration and registration of resource bundles.
   --  ------------------------------
   procedure Test_Bundle_Configuration (T : in out Test) is
      use type Util.Beans.Basic.Readonly_Bean_Access;

      Path   : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-bundle.xml");
      Result : Util.Beans.Basic.Readonly_Bean_Access;
      Ctx    : EL.Contexts.Default.Default_Context;
      Scope  : Scope_Type;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("samplesMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The samplesMsg bundle was not created");

      T.App.Create (Name    => Ada.Strings.Unbounded.To_Unbounded_String ("defaultMsg"),
                    Context => Ctx,
                    Result  => Result,
                    Scope   => Scope);
      T.Assert (Result /= null, "The defaultMsg bundle was not created");
   end Test_Bundle_Configuration;

   --  ------------------------------
   --  Test locales.
   --  ------------------------------
   procedure Test_Locales (T : in out Test) is
      use Util.Locales;

      Path      : constant String := Util.Tests.Get_Test_Path ("regtests/config/test-locales.xml");
      Req       : aliased ASF.Requests.Mockup.Request;
      View      : constant access Applications.Views.View_Handler'Class := T.App.Get_View_Handler;
      Context   : aliased ASF.Contexts.Faces.Faces_Context;
      ELContext : aliased EL.Contexts.Default.Default_Context;
      Locale    : Util.Locales.Locale;
   begin
      ASF.Applications.Main.Configs.Read_Configuration (T.App.all, Path);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (T.App.Get_Default_Locale),
                                "Invalid default locale");

      Context.Set_ELContext (ELContext'Unchecked_Access);
      Context.Set_Request (Req'Unchecked_Access);
      Req.Set_Header ("Accept-Language", "da, en-gb;q=0.3, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, en-gb, en;q=0.8, fr;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "en_GB",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, fr;q=0.7, fr-fr;q=0.8");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, "fr_FR",
                                To_String (Locale),
                                "Invalid calculated locale");

      Req.Set_Header ("Accept-Language", "da, ru, it;q=0.8, de;q=0.7");
      T.App.Set_Context (Context'Unchecked_Access);
      Locale := View.Calculate_Locale (Context);

      Util.Tests.Assert_Equals (T, To_String (Util.Locales.FRENCH),
                                To_String (Locale),
                                "Invalid calculated locale");
   end Test_Locales;

end ASF.Applications.Main.Tests;

Update and add some locale test

Update and add some locale test


-----------------------------------------------------------------------
--  asf.requests -- ASF Requests
--  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 AWS.Attachments.Extend;
with AWS.Containers.Tables;
with AWS.Parameters;

with Util.Strings;

with ASF.Parts.Web;
package body ASF.Requests.Web is

   function Get_Parameter (R : Request; Name : String) return String is
   begin
      return AWS.Status.Parameter (R.Data.all, Name);
   end Get_Parameter;

   --  ------------------------------
   --  Iterate over the request parameters and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Parameters (Req     : in Request;
                                 Process : not null access
                                   procedure (Name  : in String;
                                              Value : in String)) is
      procedure Process_Wrapper (Name, Value : in String);

      procedure Process_Wrapper (Name, Value : in String) is
         Last : Natural := Value'First;
         Pos  : Natural;
      begin
         while Last <= Value'Last loop
            Pos := Util.Strings.Index (Value, ASCII.NUL, Last);
            if Pos > 0 then
               Process (Name, Value (Last .. Pos - 1));
               Last := Pos + 1;
            else
               Process (Name, Value (Last .. Value'Last));
               return;
            end if;
         end loop;
      end Process_Wrapper;

      P : constant AWS.Parameters.List := AWS.Status.Parameters (Req.Data.all);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (P),
                                           "" & ASCII.NUL, Process_Wrapper'Access);
   end Iterate_Parameters;

   --  ------------------------------
   --  Set the AWS data received to initialize the request object.
   --  ------------------------------
   procedure Set_Request (Req  : in out Request;
                          Data : access AWS.Status.Data) is
   begin
      Req.Data    := Data;
      Req.Headers := AWS.Status.Header (Data.all);
   end Set_Request;

   --  ------------------------------
   --  Returns the name of the HTTP method with which this request was made,
   --  for example, GET, POST, or PUT. Same as the value of the CGI variable
   --  REQUEST_METHOD.
   --  ------------------------------
   function Get_Method (Req : in Request) return String is
   begin
      return AWS.Status.Method (Req.Data.all);
   end Get_Method;

   --  ------------------------------
   --  Returns the name and version of the protocol the request uses in the form
   --  protocol/majorVersion.minorVersion, for example, HTTP/1.1. For HTTP servlets,
   --  the value returned is the same as the value of the CGI variable SERVER_PROTOCOL.
   --  ------------------------------
   function Get_Protocol (Req : in Request) return String is
   begin
      return AWS.Status.HTTP_Version (Req.Data.all);
   end Get_Protocol;

   --  ------------------------------
   --  Returns the part of this request's URL from the protocol name up to the query
   --  string in the first line of the HTTP request. The web container does not decode
   --  this String. For example:
   --  First line of HTTP request    Returned Value
   --  POST /some/path.html HTTP/1.1        /some/path.html
   --  GET http://foo.bar/a.html HTTP/1.0       /a.html
   --  HEAD /xyz?a=b HTTP/1.1       /xyz
   --  ------------------------------
   function Get_Request_URI (Req : in Request) return String is
   begin
      return AWS.Status.URI (Req.Data.all);
   end Get_Request_URI;

   --  ------------------------------
   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Header (Req  : in Request;
                        Name : in String) return String is
      Values : constant AWS.Headers.VString_Array := AWS.Headers.Get_Values (Req.Headers, Name);
   begin
      if Values'Length > 0 then
         return To_String (Values (Values'First));
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Iterate over the request headers and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Headers (Req     : in Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      Req.Headers.Iterate_Names (", ",
                                 Process => Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns all the values of the specified request header as an Enumeration
   --  of String objects.
   --
   --  Some headers, such as Accept-Language can be sent by clients as several headers
   --  each with a different value rather than sending the header as a comma
   --  separated list.
   --
   --  If the request did not include any headers of the specified name, this method
   --  returns an empty Enumeration. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Headers (Req  : in Request;
                         Name : in String) return String is
   begin
      return AWS.Headers.Get_Values (Req.Headers, Name);
   end Get_Headers;

   --  ------------------------------
   --  Returns the Internet Protocol (IP) address of the client or last proxy that
   --  sent the request. For HTTP servlets, same as the value of the CGI variable
   --  REMOTE_ADDR.
   --  ------------------------------
   function Get_Remote_Addr (Req : in Request) return String is
   begin
      return AWS.Status.Peername (Req.Data.all);
   end Get_Remote_Addr;

   --  ------------------------------
   --  Get the number of parts included in the request.
   --  ------------------------------
   function Get_Part_Count (Req : in Request) return Natural is
   begin
      return AWS.Attachments.Count (AWS.Status.Attachments (Req.Data.all));
   end Get_Part_Count;

   --  ------------------------------
   --  Process the part at the given position and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Position : in Positive;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Position), Process);
   end Process_Part;

   --  ------------------------------
   --  Process the part identifed by Id and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Id       : in String;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      procedure Process_Part (E : in AWS.Attachments.Element);

      procedure Process_Part (E : in AWS.Attachments.Element) is
         Name : constant String := AWS.Attachments.Extend.Get_Name (E);
      begin
         if Id = Name then
            ASF.Parts.Web.Process_Part (E, Process);
         end if;
      end Process_Part;

      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      AWS.Attachments.Iterate (Attachs, Process_Part'Access);
--        ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Id), Process);
   end Process_Part;

end ASF.Requests.Web;

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

with Util.Strings;

with ASF.Parts.Web;
package body ASF.Requests.Web is

   function Get_Parameter (R : Request; Name : String) return String is
   begin
      return AWS.Status.Parameter (R.Data.all, Name);
   end Get_Parameter;

   --  ------------------------------
   --  Iterate over the request parameters and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Parameters (Req     : in Request;
                                 Process : not null access
                                   procedure (Name  : in String;
                                              Value : in String)) is
      procedure Process_Wrapper (Name, Value : in String);

      procedure Process_Wrapper (Name, Value : in String) is
         Last : Natural := Value'First;
         Pos  : Natural;
      begin
         while Last <= Value'Last loop
            Pos := Util.Strings.Index (Value, ASCII.NUL, Last);
            if Pos > 0 then
               Process (Name, Value (Last .. Pos - 1));
               Last := Pos + 1;
            else
               Process (Name, Value (Last .. Value'Last));
               return;
            end if;
         end loop;
      end Process_Wrapper;

      P : constant AWS.Parameters.List := AWS.Status.Parameters (Req.Data.all);
   begin
      AWS.Containers.Tables.Iterate_Names (AWS.Containers.Tables.Table_Type (P),
                                           "" & ASCII.NUL, Process_Wrapper'Access);
   end Iterate_Parameters;

   --  ------------------------------
   --  Set the AWS data received to initialize the request object.
   --  ------------------------------
   procedure Set_Request (Req  : in out Request;
                          Data : access AWS.Status.Data) is
   begin
      Req.Data    := Data;
      Req.Headers := AWS.Status.Header (Data.all);
   end Set_Request;

   --  ------------------------------
   --  Returns the name of the HTTP method with which this request was made,
   --  for example, GET, POST, or PUT. Same as the value of the CGI variable
   --  REQUEST_METHOD.
   --  ------------------------------
   function Get_Method (Req : in Request) return String is
   begin
      return AWS.Status.Method (Req.Data.all);
   end Get_Method;

   --  ------------------------------
   --  Returns the name and version of the protocol the request uses in the form
   --  protocol/majorVersion.minorVersion, for example, HTTP/1.1. For HTTP servlets,
   --  the value returned is the same as the value of the CGI variable SERVER_PROTOCOL.
   --  ------------------------------
   function Get_Protocol (Req : in Request) return String is
   begin
      return AWS.Status.HTTP_Version (Req.Data.all);
   end Get_Protocol;

   --  ------------------------------
   --  Returns the part of this request's URL from the protocol name up to the query
   --  string in the first line of the HTTP request. The web container does not decode
   --  this String. For example:
   --  First line of HTTP request    Returned Value
   --  POST /some/path.html HTTP/1.1        /some/path.html
   --  GET http://foo.bar/a.html HTTP/1.0       /a.html
   --  HEAD /xyz?a=b HTTP/1.1       /xyz
   --  ------------------------------
   function Get_Request_URI (Req : in Request) return String is
   begin
      return AWS.Status.URI (Req.Data.all);
   end Get_Request_URI;

   --  ------------------------------
   --  Returns the value of the specified request header as a String. If the request
   --  did not include a header of the specified name, this method returns null.
   --  If there are multiple headers with the same name, this method returns the
   --  first head in the request. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Header (Req  : in Request;
                        Name : in String) return String is
      Values : constant AWS.Headers.VString_Array := AWS.Headers.Get_Values (Req.Headers, Name);
   begin
      if Values'Length > 0 then
         return To_String (Values (Values'First));
      else
         return "";
      end if;
   end Get_Header;

   --  ------------------------------
   --  Iterate over the request headers and executes the Process procedure.
   --  ------------------------------
   procedure Iterate_Headers (Req     : in Request;
                              Process : not null access
                                procedure (Name  : in String;
                                           Value : in String)) is
   begin
      Req.Headers.Iterate_Names (", ",
                                 Process => Process);
   end Iterate_Headers;

   --  ------------------------------
   --  Returns all the values of the specified request header as an Enumeration
   --  of String objects.
   --
   --  Some headers, such as Accept-Language can be sent by clients as several headers
   --  each with a different value rather than sending the header as a comma
   --  separated list.
   --
   --  If the request did not include any headers of the specified name, this method
   --  returns an empty Enumeration. The header name is case insensitive. You can use
   --  this method with any request header.
   --  ------------------------------
   function Get_Headers (Req  : in Request;
                         Name : in String) return String is
   begin
      return AWS.Headers.Get_Values (Req.Headers, Name);
   end Get_Headers;

   --  ------------------------------
   --  Returns the Internet Protocol (IP) address of the client or last proxy that
   --  sent the request. For HTTP servlets, same as the value of the CGI variable
   --  REMOTE_ADDR.
   --  ------------------------------
   function Get_Remote_Addr (Req : in Request) return String is
   begin
      return AWS.Status.Peername (Req.Data.all);
   end Get_Remote_Addr;

   --  ------------------------------
   --  Get the number of parts included in the request.
   --  ------------------------------
   function Get_Part_Count (Req : in Request) return Natural is
   begin
      return AWS.Attachments.Count (AWS.Status.Attachments (Req.Data.all));
   end Get_Part_Count;

   --  ------------------------------
   --  Process the part at the given position and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Position : in Positive;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Position), Process);
   end Process_Part;

   --  ------------------------------
   --  Process the part identifed by Id and executes the Process operation
   --  with the part object.
   --  ------------------------------
   procedure Process_Part (Req      : in out Request;
                           Id       : in String;
                           Process  : not null access
                             procedure (Data : in ASF.Parts.Part'Class)) is
      procedure Process_Part (E : in AWS.Attachments.Element);

      procedure Process_Part (E : in AWS.Attachments.Element) is
         Name : constant String := AWS.Attachments.Extend.Get_Name (E);
      begin
         if Id = Name then
            ASF.Parts.Web.Process_Part (E, Process);
         end if;
      end Process_Part;

      Attachs : constant AWS.Attachments.List := AWS.Status.Attachments (Req.Data.all);
   begin
      AWS.Attachments.Iterate (Attachs, Process_Part'Access);
--        ASF.Parts.Web.Process_Part (AWS.Attachments.Get (Attachs, Id), Process);
   end Process_Part;

   --  ------------------------------
   --  Read into the buffer as many bytes as possible and return in
   --  last the position of the last byte read.
   --  ------------------------------
   overriding
   procedure Read (Stream : in out Request;
                   Into   : out Ada.Streams.Stream_Element_Array;
                   Last   : out Ada.Streams.Stream_Element_Offset) is
   begin
      AWS.Status.Read_Body (D      => Stream.Data.all,
                            Buffer => Into,
                            Last   => Last);
   end Read;

   overriding
   function Create_Input_Stream (Req : in Request) return ASF.Streams.Input_Stream_Access is
      Result : constant ASF.Streams.Input_Stream_Access := new ASF.Streams.Input_Stream;
   begin
      Result.Initialize (Output => null,
                         Input  => Req'Unrestricted_Access,
                         Size   => 8192);
      return Result;
   end Create_Input_Stream;

end ASF.Requests.Web;

Implement the Read and Create_Input_Stream operations