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

with Util.Strings;

with Security.OAuth.Servers;
private with Util.Strings.Maps;
package Security.OAuth.File_Registry is

   type File_Principal is new Security.Principal with private;
   type File_Principal_Access is access all File_Principal'Class;

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

   type File_Application_Manager is new Servers.Application_Manager with private;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   overriding
   function Find_Application (Realm     : in File_Application_Manager;
                              Client_Id : in String) return Servers.Application'Class;

   type File_Realm_Manager is new Servers.Realm_Manager with private;

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

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

   overriding
   procedure Verify (Realm    : in out File_Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access);

   overriding
   procedure Verify (Realm : in out File_Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access);

   overriding
   procedure Revoke (Realm : in out File_Realm_Manager;
                     Auth  : in Principal_Access);

private

   use Ada.Strings.Unbounded;

   package Application_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Servers.Application,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => Servers."=");

   package Token_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => File_Principal_Access,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   package User_Maps renames Util.Strings.Maps;

   type File_Principal is new Security.Principal with record
      Token : Ada.Strings.Unbounded.Unbounded_String;
      Name  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type File_Application_Manager is new Servers.Application_Manager with record
      Applications : Application_Maps.Map;
   end record;

   type File_Realm_Manager is new Servers.Realm_Manager with record
      Users  : User_Maps.Map;
      Tokens : Token_Maps.Map;
   end record;

end Security.OAuth.File_Registry;

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

with Util.Strings;

with Security.OAuth.Servers;
private with Util.Strings.Maps;
private with Security.Random;
package Security.OAuth.File_Registry is

   type File_Principal is new Security.Principal with private;
   type File_Principal_Access is access all File_Principal'Class;

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

   type File_Application_Manager is new Servers.Application_Manager with private;

   --  Find the application that correspond to the given client id.
   --  The <tt>Invalid_Application</tt> exception should be raised if there is no such application.
   overriding
   function Find_Application (Realm     : in File_Application_Manager;
                              Client_Id : in String) return Servers.Application'Class;

   --  Add the application to the application repository.
   procedure Add_Application (Realm : in out File_Application_Manager;
                              App   : in Servers.Application);

   type File_Realm_Manager is limited new Servers.Realm_Manager with private;

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

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

   overriding
   procedure Verify (Realm    : in out File_Realm_Manager;
                     Username : in String;
                     Password : in String;
                     Auth     : out Principal_Access);

   overriding
   procedure Verify (Realm : in out File_Realm_Manager;
                     Token : in String;
                     Auth  : out Principal_Access);

   overriding
   procedure Revoke (Realm : in out File_Realm_Manager;
                     Auth  : in Principal_Access);

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

   --  Add a username with the associated password.
   procedure Add_User (Realm    : in out File_Realm_Manager;
                       Username : in String;
                       Password : in String);

private

   use Ada.Strings.Unbounded;

   package Application_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => Servers.Application,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => Servers."=");

   package Token_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => File_Principal_Access,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=",
                                                "="             => "=");

   package User_Maps renames Util.Strings.Maps;

   type File_Principal is new Security.Principal with record
      Token : Ada.Strings.Unbounded.Unbounded_String;
      Name  : Ada.Strings.Unbounded.Unbounded_String;
   end record;

   type File_Application_Manager is new Servers.Application_Manager with record
      Applications : Application_Maps.Map;
   end record;

   type File_Realm_Manager is limited new Servers.Realm_Manager with record
      Users      : User_Maps.Map;
      Tokens     : Token_Maps.Map;
      Random     : Security.Random.Generator;
      Token_Bits : Positive := 256;
   end record;

end Security.OAuth.File_Registry;

Declare the Add_Application procedure Declare the Crypt_Password and Add_User procedures


-----------------------------------------------------------------------
--  util-http-clients-tests -- Unit tests for HTTP client
--  Copyright (C) 2012, 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 Ada.Unchecked_Deallocation;

with Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Head",
                          Test_Http_Head'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Put",
                          Test_Http_Put'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Delete",
                          Test_Http_Delete'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Options",
                          Test_Http_Options'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Patch",
                          Test_Http_Patch'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get (timeout)",
                          Test_Http_Timeout'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "HEAD" then
            Into.Method := HEAD;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         elsif L (L'First .. Pos - 1) = "PUT" then
            Into.Method := PUT;
         elsif L (L'First .. Pos - 1) = "DELETE" then
            Into.Method := DELETE;
         elsif L (L'First .. Pos - 1) = "OPTIONS" then
            Into.Method := OPTIONS;
         elsif L (L'First .. Pos - 1) = "PATCH" then
            Into.Method := PATCH;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;

      --  Don't answer if we check the timeout.
      if Into.Test_Timeout then
         return;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      elsif L'Length = 2 then
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 204 No Content" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      Request.Set_Timeout (5.0);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http HEAD operation.
   --  ------------------------------
   procedure Test_Http_Head (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Head ("http://www.google.com", Reply);
      Request.Set_Timeout (5.0);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_head.txt"), Reply, True);

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Head;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

   --  ------------------------------
   --  Test the http PUT operation.
   --  ------------------------------
   procedure Test_Http_Put (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Put on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Put (Uri & "/put",
                   "p1=1", Reply);

      T.Assert (T.Server.Method = PUT, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_put.txt"), Reply, True);

   end Test_Http_Put;

   --  ------------------------------
   --  Test the http DELETE operation.
   --  ------------------------------
   procedure Test_Http_Delete (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Delete (Uri & "/delete", Reply);

      T.Assert (T.Server.Method = DELETE, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Delete;

   --  ------------------------------
   --  Test the http OPTIONS operation.
   --  ------------------------------
   procedure Test_Http_Options (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Options (Uri & "/options", Reply);

      T.Assert (T.Server.Method = OPTIONS, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Options;

   --  ------------------------------
   --  Test the http PATCH operation.
   --  ------------------------------
   procedure Test_Http_Patch (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Patch on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Patch (Uri & "/patch", "patch-content", Reply);

      T.Assert (T.Server.Method = PATCH, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, 200, Reply.Get_Status, "Invalid status response");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");

   end Test_Http_Patch;

   --  ------------------------------
   --  Test the http timeout.
   --  ------------------------------
   procedure Test_Http_Timeout (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Timeout on " & Uri);

      T.Server.Test_Timeout := True;
      T.Server.Method := UNKNOWN;
      Request.Set_Timeout (0.5);
      begin
         Request.Get (Uri & "/timeout", Reply);
         T.Fail ("No Connection_Error exception raised");

      exception
         when Connection_Error =>
            null;
      end;

   end Test_Http_Timeout;

end Util.Http.Clients.Tests;

-----------------------------------------------------------------------
--  util-http-clients-tests -- Unit tests for HTTP client
--  Copyright (C) 2012, 2020, 2021 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.Unchecked_Deallocation;

with Util.Test_Caller;

with Util.Strings.Transforms;
with Util.Http.Tools;
with Util.Strings;
with Util.Log.Loggers;

package body Util.Http.Clients.Tests is

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Http.Clients.Tests");

   package body Http_Tests is
      package Caller is new Util.Test_Caller (Http_Test, "Http-" & NAME);

      procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
      begin
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get",
                          Test_Http_Get'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Head",
                          Test_Http_Head'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Post",
                          Test_Http_Post'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Put",
                          Test_Http_Put'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Delete",
                          Test_Http_Delete'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Options",
                          Test_Http_Options'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Patch",
                          Test_Http_Patch'Access);
         Caller.Add_Test (Suite, "Test Util.Http.Clients." & NAME & ".Get (timeout)",
                          Test_Http_Timeout'Access);
      end Add_Tests;

      overriding
      procedure Set_Up (T : in out Http_Test) is
      begin
         Test (T).Set_Up;
         Register;
      end Set_Up;

   end Http_Tests;

   overriding
   procedure Set_Up (T : in out Test) is
   begin
      Log.Info ("Starting test server");
      T.Server := new Test_Server;
      T.Server.Start;
   end Set_Up;

   overriding
   procedure Tear_Down (T : in out Test) is
      procedure Free is
         new Ada.Unchecked_Deallocation (Object => Test_Server'Class,
                                         Name   => Test_Server_Access);
   begin
      if T.Server /= null then
         Log.Info ("Stopping test server");
         T.Server.Stop;
         Free (T.Server);
         T.Server := null;
      end if;
   end Tear_Down;

   --  ------------------------------
   --  Process the line received by the server.
   --  ------------------------------
   overriding
   procedure Process_Line (Into   : in out Test_Server;
                           Line   : in Ada.Strings.Unbounded.Unbounded_String;
                           Stream : in out Util.Streams.Texts.Reader_Stream'Class;
                           Client : in out Util.Streams.Sockets.Socket_Stream'Class) is
      L   : constant String := Ada.Strings.Unbounded.To_String (Line);
      Pos : Natural := Util.Strings.Index (L, ' ');
   begin
      if Pos > 0 and Into.Method = UNKNOWN then
         if L (L'First .. Pos - 1) = "GET" then
            Into.Method := GET;
         elsif L (L'First .. Pos - 1) = "HEAD" then
            Into.Method := HEAD;
         elsif L (L'First .. Pos - 1) = "POST" then
            Into.Method := POST;
         elsif L (L'First .. Pos - 1) = "PUT" then
            Into.Method := PUT;
         elsif L (L'First .. Pos - 1) = "DELETE" then
            Into.Method := DELETE;
         elsif L (L'First .. Pos - 1) = "OPTIONS" then
            Into.Method := OPTIONS;
         elsif L (L'First .. Pos - 1) = "PATCH" then
            Into.Method := PATCH;
         else
            Into.Method := UNKNOWN;
         end if;
      end if;

      Pos := Util.Strings.Index (L, ':');
      if Pos > 0 then
         if L (L'First .. Pos) = "Content-Type:" then
            Into.Content_Type
              := Ada.Strings.Unbounded.To_Unbounded_String (L (Pos + 2 .. L'Last - 2));
         elsif L (L'First .. Pos) = "Content-Length:" then
            Into.Length := Natural'Value (L (Pos + 1 .. L'Last - 2));

         end if;
      end if;

      --  Don't answer if we check the timeout.
      if Into.Test_Timeout then
         return;
      end if;
      if L'Length = 2 and then Into.Length > 0 then
         for I in 1 .. Into.Length loop
            declare
               C : Character;
            begin
               Stream.Read (C);
               Ada.Strings.Unbounded.Append (Into.Result, C);
            end;
         end loop;
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 200 Found" & ASCII.CR & ASCII.LF);
            Output.Write ("Content-Length: 4" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Write ("OK" & ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      elsif L'Length = 2 then
         declare
            Output : Util.Streams.Texts.Print_Stream;
         begin
            Output.Initialize (Client'Unchecked_Access);
            Output.Write ("HTTP/1.1 204 No Content" & ASCII.CR & ASCII.LF);
            Output.Write (ASCII.CR & ASCII.LF);
            Output.Flush;
         end;
      end if;
      Log.Info ("Received: {0}", L);
   end Process_Line;

   --  ------------------------------
   --  Get the test server base URI.
   --  ------------------------------
   function Get_Uri (T : in Test) return String is

   begin
      return "http://" & T.Server.Get_Host & ":" & Util.Strings.Image (T.Server.Get_Port);
   end Get_Uri;

   --  ------------------------------
   --  Test the http Get operation.
   --  ------------------------------
   procedure Test_Http_Get (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Get ("http://www.google.com", Reply);
      Request.Set_Timeout (5.0);
      Request.Set_Header ("Accept", "text/html");
      Util.Http.Add_Int_Header (Request, "DNT", 0);
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_get.txt"), Reply, True);

      --  Check the content.
      declare
         Content : constant String := Util.Strings.Transforms.To_Lower_Case (Reply.Get_Body);
      begin
         Util.Tests.Assert_Matches (T, ".*html.*", Content, "Invalid GET content");
      end;

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Get;

   --  ------------------------------
   --  Test the http HEAD operation.
   --  ------------------------------
   procedure Test_Http_Head (T : in out Test) is
      Request : Client;
      Reply   : Response;
   begin
      Request.Head ("http://www.google.com", Reply);
      Request.Set_Timeout (5.0);
      Request.Add_Header ("Accept", "text/html");
      T.Assert (Reply.Get_Status = 200 or Reply.Get_Status = 302,
                "Get status is invalid: " & Natural'Image (Reply.Get_Status));

      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_head.txt"), Reply, True);

      T.Assert (Reply.Contains_Header ("Content-Type"), "Header Content-Type not found");
      T.Assert (not Reply.Contains_Header ("Content-Type-Invalid-Missing"),
                "Some invalid header found");

      --  Check one header.
      declare
         Content : constant String := Reply.Get_Header ("Content-Type");
      begin
         T.Assert (Content'Length > 0, "Empty Content-Type header");
         Util.Tests.Assert_Matches (T, ".*text/html.*", Content, "Invalid content type");
      end;
   end Test_Http_Head;

   --  ------------------------------
   --  Test the http POST operation.
   --  ------------------------------
   procedure Test_Http_Post (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Post on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Post (Uri & "/post",
                    "p1=1", Reply);

      T.Assert (T.Server.Method = POST, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_post.txt"), Reply, True);

   end Test_Http_Post;

   --  ------------------------------
   --  Test the http PUT operation.
   --  ------------------------------
   procedure Test_Http_Put (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Put on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Put (Uri & "/put",
                   "p1=1", Reply);

      T.Assert (T.Server.Method = PUT, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");
      Util.Http.Tools.Save_Response (Util.Tests.Get_Test_Path ("http_put.txt"), Reply, True);

   end Test_Http_Put;

   --  ------------------------------
   --  Test the http DELETE operation.
   --  ------------------------------
   procedure Test_Http_Delete (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Delete (Uri & "/delete", Reply);

      T.Assert (T.Server.Method = DELETE, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Delete;

   --  ------------------------------
   --  Test the http OPTIONS operation.
   --  ------------------------------
   procedure Test_Http_Options (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Delete on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Options (Uri & "/options", Reply);

      T.Assert (T.Server.Method = OPTIONS, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, "", Reply.Get_Body, "Invalid response");
      Util.Tests.Assert_Equals (T, 204, Reply.Get_Status, "Invalid status response");

   end Test_Http_Options;

   --  ------------------------------
   --  Test the http PATCH operation.
   --  ------------------------------
   procedure Test_Http_Patch (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Patch on " & Uri);

      T.Server.Method := UNKNOWN;
      Request.Add_Header ("Content-Type", "application/x-www-form-urlencoded");
      Request.Set_Timeout (1.0);
      T.Assert (Request.Contains_Header ("Content-Type"), "Missing Content-Type");
      Request.Patch (Uri & "/patch", "patch-content", Reply);

      T.Assert (T.Server.Method = PATCH, "Invalid method received by server");
      Util.Tests.Assert_Equals (T, "application/x-www-form-urlencoded", T.Server.Content_Type,
                                "Invalid content type received by server");
      Util.Tests.Assert_Equals (T, 200, Reply.Get_Status, "Invalid status response");
      Util.Tests.Assert_Equals (T, "OK" & ASCII.CR & ASCII.LF, Reply.Get_Body, "Invalid response");

   end Test_Http_Patch;

   --  ------------------------------
   --  Test the http timeout.
   --  ------------------------------
   procedure Test_Http_Timeout (T : in out Test) is
      Request : Client;
      Reply   : Response;
      Uri     : constant String := T.Get_Uri;
   begin
      Log.Info ("Timeout on " & Uri);

      T.Server.Test_Timeout := True;
      T.Server.Method := UNKNOWN;
      Request.Set_Timeout (0.5);
      begin
         Request.Get (Uri & "/timeout", Reply);
         T.Fail ("No Connection_Error exception raised");

      exception
         when Connection_Error =>
            null;
      end;

   end Test_Http_Timeout;

end Util.Http.Clients.Tests;

Add some headers in http requests for the tests


-----------------------------------------------------------------------
--  gen-model-list -- List bean interface for model objects
--  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 Gen.Model.List is

   --  ------------------------------
   --  Get the first item of the list
   --  ------------------------------
   function First (Def : List_Definition) return Cursor is
   begin
      return Def.Nodes.First;
   end First;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   function Get_Count (From : List_Definition) return Natural is
      Count : constant Natural := Natural (From.Nodes.Length);
   begin
      return Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   procedure Set_Row_Index (From  : in out List_Definition;
                            Index : in Natural) is
   begin
      From.Row := Index;
      if Index > 0 then
         declare
            Current : constant T_Access := From.Nodes.Element (Index - 1);
            Bean    : constant EL.Beans.Readonly_Bean_Access := Current.all'Access;
         begin
            From.Value_Bean := EL.Objects.To_Object (Bean);
         end;
      else
         From.Value_Bean := EL.Objects.Null_Object;
      end if;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   function Get_Row (From  : List_Definition) return EL.Objects.Object is
   begin
      return From.Value_Bean;
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : List_Definition;
                       Name : String) return EL.Objects.Object is
      pragma Unreferenced (Name);
      pragma Unreferenced (From);
   begin
      return EL.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Append the item in the list
   --  ------------------------------
   procedure Append (Def  : in out List_Definition;
                     Item : in T_Access) is
   begin
      Def.Nodes.Append (Item);
   end Append;

end Gen.Model.List;

-----------------------------------------------------------------------
--  gen-model-list -- List bean interface for model objects
--  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 Gen.Model.List is

   --  ------------------------------
   --  Get the first item of the list
   --  ------------------------------
   function First (Def : List_Definition) return Cursor is
   begin
      return Def.Nodes.First;
   end First;

   --  ------------------------------
   --  Get the number of elements in the list.
   --  ------------------------------
   function Get_Count (From : List_Definition) return Natural is
      Count : constant Natural := Natural (From.Nodes.Length);
   begin
      return Count;
   end Get_Count;

   --  ------------------------------
   --  Set the current row index.  Valid row indexes start at 1.
   --  ------------------------------
   procedure Set_Row_Index (From  : in out List_Definition;
                            Index : in Natural) is
   begin
      From.Row := Index;
      if Index > 0 then
         declare
            Current : constant T_Access := From.Nodes.Element (Index - 1);
            Bean    : constant EL.Beans.Readonly_Bean_Access := Current.all'Access;
         begin
            From.Value_Bean := EL.Objects.To_Object (Bean);
         end;
      else
         From.Value_Bean := EL.Objects.Null_Object;
      end if;
   end Set_Row_Index;

   --  ------------------------------
   --  Get the element at the current row index.
   --  ------------------------------
   function Get_Row (From  : List_Definition) return EL.Objects.Object is
   begin
      return From.Value_Bean;
   end Get_Row;

   --  ------------------------------
   --  Get the value identified by the name.
   --  If the name cannot be found, the method should return the Null object.
   --  ------------------------------
   function Get_Value (From : List_Definition;
                       Name : String) return EL.Objects.Object is
   begin
      if Name = "size" then
         return EL.Objects.To_Object (From.Get_Count);
      end if;
      return EL.Objects.Null_Object;
   end Get_Value;

   --  ------------------------------
   --  Append the item in the list
   --  ------------------------------
   procedure Append (Def  : in out List_Definition;
                     Item : in T_Access) is
   begin
      Def.Nodes.Append (Item);
   end Append;

end Gen.Model.List;

Add a 'size' attribute to value lists

Add a 'size' attribute to value lists


-----------------------------------------------------------------------
--  awa -- Ada Web Application
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2016, 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 ASF.Requests;
with ASF.Responses;
with ASF.Server;
with Ada.IO_Exceptions;

with Util.Files;
with Util.Properties;

with EL.Contexts.Default;

with AWA.Modules.Reader;
with AWA.Applications;
package body AWA.Modules is

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module_Manager;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Module.all.Get_Config (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module_Manager;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Module.all.Get_Config (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module name
   --  ------------------------------
   function Get_Name (Plugin : in Module) return String is
   begin
      return To_String (Plugin.Name);
   end Get_Name;

   --  ------------------------------
   --  Get the base URI for this module
   --  ------------------------------
   function Get_URI (Plugin : in Module) return String is
   begin
      return To_String (Plugin.URI);
   end Get_URI;

   --  ------------------------------
   --  Get the application in which this module is registered.
   --  ------------------------------
   function Get_Application (Plugin : in Module) return Application_Access is
   begin
      return Plugin.App;
   end Get_Application;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Config.Get (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Integer := -1) return Integer is
      Value : constant String := Plugin.Config.Get (Name, Integer'Image (Default));
   begin
      return Integer'Value (Value);

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Boolean := False) return Boolean is
      Value : constant String := Plugin.Config.Get (Name, Boolean'Image (Default));
   begin
      if Value in "yes" | "true" | "1" then
         return True;
      else
         return False;
      end if;

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Config.Get (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in String := "")
                        return EL.Expressions.Expression is

      type Event_ELResolver is new EL.Contexts.Default.Default_ELResolver with null record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
      begin
         if Base /= null then
            return EL.Contexts.Default.Default_ELResolver (Resolver).Get_Value (Context, Base,
                                                                                Name);
         else
            return Util.Beans.Objects.To_Object (Plugin.Get_Config (To_String (Name), ""));
         end if;
      end Get_Value;

      Resolver : aliased Event_ELResolver;
      Context  : EL.Contexts.Default.Default_Context;
      Value    : constant String := Plugin.Get_Config (Name, Default);
   begin
      Context.Set_Resolver (Resolver'Unchecked_Access);
      return EL.Expressions.Reduce_Expression (EL.Expressions.Create_Expression (Value, Context),
                                               Context);

   exception
      when E : others =>
         Log.Error ("Invalid parameter ", E, True);
         return EL.Expressions.Create_Expression ("", Context);

   end Get_Config;

   --  ------------------------------
   --  Send the event to the module
   --  ------------------------------
   procedure Send_Event (Plugin  : in Module;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Plugin.App.Send_Event (Content);
   end Send_Event;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (Plugin : Module;
                         Name   : String) return Module_Access is
   begin
      if Plugin.Registry = null then
         return null;
      end if;
      return Find_By_Name (Plugin.Registry.all, Name);
   end Find_Module;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Plugin : in out Module;
                       Name    : in String;
                       Bind    : in ASF.Beans.Class_Binding_Access) is
   begin
      Plugin.App.Register_Class (Name, Bind);
   end Register;

   --  ------------------------------
   --  Finalize the module.
   --  ------------------------------
   overriding
   procedure Finalize (Plugin : in out Module) is
   begin
      null;
   end Finalize;

   procedure Initialize (Manager : in out Module_Manager;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      Manager.Module := Module.Self;
   end Initialize;

   function Get_Value (Manager : in Module_Manager;
                       Name    : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Manager, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Module manager
   --
   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module_Manager)
                            return ADO.Sessions.Session is
   begin
      return Manager.Module.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module_Manager)
                                   return ADO.Sessions.Master_Session is
   begin
      return Manager.Module.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Send the event to the module.  The module identified by To is
   --  found and the event is posted on its event channel.
   --  ------------------------------
   procedure Send_Event (Manager : in Module_Manager;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Manager.Module.Send_Event (Content);
   end Send_Event;

   procedure Initialize (Plugin : in out Module;
                         App    : in Application_Access;
                         Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Self := Plugin'Unchecked_Access;
      Plugin.App := App;
   end Initialize;

   --  ------------------------------
   --  Initialize the registry
   --  ------------------------------
   procedure Initialize (Registry : in out Module_Registry;
                         Config   : in ASF.Applications.Config) is
   begin
      Registry.Config := Config;
   end Initialize;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Register (Registry : in Module_Registry_Access;
                       App      : in Application_Access;
                       Plugin   : in Module_Access;
                       Name     : in String;
                       URI      : in String) is
      procedure Copy (Params : in Util.Properties.Manager'Class);

      procedure Copy (Params : in Util.Properties.Manager'Class) is
      begin
         Plugin.Config.Copy (From => Params, Prefix => Name & ".", Strip => True);
      end Copy;

      Paths : constant String := Registry.Config.Get (Applications.P_Module_Dir.P);
   begin
      Log.Info ("Register module '{0}' under URI '{1}'", Name, URI);

      if Plugin.Registry /= null then
         Log.Error ("Module '{0}' is already attached to a registry", Name);

         raise Program_Error with "Module '" & Name & "' already registered";
      end if;
      Plugin.App      := App;
      Plugin.Registry := Registry;
      Plugin.Name     := To_Unbounded_String (Name);
      Plugin.URI      := To_Unbounded_String (URI);
      Plugin.Registry.Name_Map.Insert (Name, Plugin);
      if URI /= "" then
         Plugin.Registry.URI_Map.Insert (URI, Plugin);
      end if;

      --  Load the module configuration file
      Log.Debug ("Module search path: {0}", Paths);
      declare
         Base  : constant String := Name & ".properties";
         Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      begin
         Plugin.Config.Load_Properties (Path => Path, Prefix => Name & ".", Strip => True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Info ("Module configuration file '{0}' does not exist", Path);
      end;

      Plugin.Initialize (App, Plugin.Config);

      --  Read the module XML configuration file if there is one.
      declare
         Base : constant String := Plugin.Config.Get ("config", Name & ".xml");
         Path : constant String := Util.Files.Find_File_Path (Base, Paths);
         Ctx  : aliased EL.Contexts.Default.Default_Context;
      begin
         AWA.Modules.Reader.Read_Configuration (Plugin.all, Path, Ctx'Unchecked_Access);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Module configuration file '{0}' does not exist", Path);
      end;

      --  Override the module configuration with the application configuration
      App.Get_Init_Parameters (Copy'Access);

      Plugin.Configure (Plugin.Config);

   exception
      when Constraint_Error =>
         Log.Error ("Another module is already registered "
                    & "under name '{0}' or URI '{1}'", Name, URI);
         raise;
   end Register;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_By_Name (Registry : Module_Registry;
                          Name     : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.Name_Map, Name);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_Name;

   --  ------------------------------
   --  Find the module mapped to a given URI
   --  ------------------------------
   function Find_By_URI (Registry : Module_Registry;
                         URI      : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.URI_Map, URI);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_URI;

   --  ------------------------------
   --  Iterate over the modules that have been registered and execute the Process
   --  procedure on each of the module instance.
   --  ------------------------------
   procedure Iterate (Registry : in Module_Registry;
                      Process  : access procedure (Plugin : in out Module'Class)) is
      Iter : Module_Maps.Cursor := Registry.Name_Map.First;
   begin
      while Module_Maps.Has_Element (Iter) loop
         Process (Module_Maps.Element (Iter).all);
         Module_Maps.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module)
                            return ADO.Sessions.Session is
   begin
      return Manager.App.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
   begin
      return Manager.App.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Add a listener to the module listner list.  The module will invoke the listner
   --  depending on events or actions that occur in the module.
   --  ------------------------------
   procedure Add_Listener (Into : in out Module;
                           Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Add_Listener (Into.Listeners, Item);
   end Add_Listener;

   --  ------------------------------
   --  Find the module with the given name in the application and add the listener to the
   --  module listener list.
   --  ------------------------------
   procedure Add_Listener (Plugin : in Module;
                           Name   : in String;
                           Item   : in Util.Listeners.Listener_Access) is
      M : constant Module_Access := Plugin.App.Find_Module (Name);
   begin
      if M = null then
         Log.Error ("Cannot find module {0} to add a lifecycle listener", Name);
      else
         M.Add_Listener (Item);
      end if;
   end Add_Listener;

   --  ------------------------------
   --  Remove a listener from the module listener list.
   --  ------------------------------
   procedure Remove_Listener (Into : in out Module;
                              Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Remove_Listener (Into.Listeners, Item);
   end Remove_Listener;

   --  Get per request manager => look in Request
   --  Get per session manager => look in Request.Get_Session
   --  Get per application manager => look in Application
   --  Get per pool manager => look in pool attached to Application
   function Get_Manager return Manager_Type_Access is

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class);

      Value : Util.Beans.Objects.Object;

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class) is
         pragma Unreferenced (Response);
      begin
         Value := Request.Get_Attribute (Name);
         if Util.Beans.Objects.Is_Null (Value) then
            declare
               M : constant Manager_Type_Access := new Manager_Type;
            begin
               Value := Util.Beans.Objects.To_Object (M.all'Unchecked_Access);
               Request.Set_Attribute (Name, Value);
            end;
         end if;
      end Process;

   begin
      ASF.Server.Update_Context (Process'Access);
      if Util.Beans.Objects.Is_Null (Value) then
         return null;
      end if;
      declare
         B : constant access Util.Beans.Basic.Readonly_Bean'Class
           := Util.Beans.Objects.To_Bean (Value);
      begin
         if not (B.all in Manager_Type'Class) then
            return null;
         end if;
         return Manager_Type'Class (B.all)'Unchecked_Access;
      end;
   end Get_Manager;

end AWA.Modules;

-----------------------------------------------------------------------
--  awa -- Ada Web Application
--  Copyright (C) 2009, 2010, 2011, 2012, 2015, 2016, 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 ASF.Requests;
with ASF.Responses;
with ASF.Server;
with Ada.IO_Exceptions;

with Util.Files;
with Util.Properties;

with EL.Contexts.Default;

with AWA.Modules.Reader;
with AWA.Services.Contexts;
with AWA.Applications;
package body AWA.Modules is

   package ASC renames AWA.Services.Contexts;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module_Manager;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Module.all.Get_Config (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module_Manager;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Module.all.Get_Config (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module name
   --  ------------------------------
   function Get_Name (Plugin : in Module) return String is
   begin
      return To_String (Plugin.Name);
   end Get_Name;

   --  ------------------------------
   --  Get the base URI for this module
   --  ------------------------------
   function Get_URI (Plugin : in Module) return String is
   begin
      return To_String (Plugin.URI);
   end Get_URI;

   --  ------------------------------
   --  Get the application in which this module is registered.
   --  ------------------------------
   function Get_Application (Plugin : in Module) return Application_Access is
   begin
      return Plugin.App;
   end Get_Application;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : Module;
                        Name    : String;
                        Default : String := "") return String is
   begin
      return Plugin.Config.Get (Name, Default);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Integer := -1) return Integer is
      Value : constant String := Plugin.Config.Get (Name, Integer'Image (Default));
   begin
      return Integer'Value (Value);

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the name.
   --  If the configuration property does not exist, returns the default value.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in Boolean := False) return Boolean is
      Value : constant String := Plugin.Config.Get (Name, Boolean'Image (Default));
   begin
      if Value in "yes" | "true" | "1" then
         return True;
      else
         return False;
      end if;

   exception
      when Constraint_Error =>
         return Default;
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin : in Module;
                        Config : in ASF.Applications.Config_Param) return String is
   begin
      return Plugin.Config.Get (Config);
   end Get_Config;

   --  ------------------------------
   --  Get the module configuration property identified by the <tt>Config</tt> parameter.
   --  If the property does not exist, the default configuration value is returned.
   --  ------------------------------
   function Get_Config (Plugin  : in Module;
                        Name    : in String;
                        Default : in String := "")
                        return EL.Expressions.Expression is

      type Event_ELResolver is new EL.Contexts.Default.Default_ELResolver with null record;

      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object;

      --  ------------------------------
      --  Get the value associated with a base object and a given property.
      --  ------------------------------
      overriding
      function Get_Value (Resolver : Event_ELResolver;
                          Context  : EL.Contexts.ELContext'Class;
                          Base     : access Util.Beans.Basic.Readonly_Bean'Class;
                          Name     : Unbounded_String) return Util.Beans.Objects.Object is
      begin
         if Base /= null then
            return EL.Contexts.Default.Default_ELResolver (Resolver).Get_Value (Context, Base,
                                                                                Name);
         else
            return Util.Beans.Objects.To_Object (Plugin.Get_Config (To_String (Name), ""));
         end if;
      end Get_Value;

      Resolver : aliased Event_ELResolver;
      Context  : EL.Contexts.Default.Default_Context;
      Value    : constant String := Plugin.Get_Config (Name, Default);
   begin
      Context.Set_Resolver (Resolver'Unchecked_Access);
      return EL.Expressions.Reduce_Expression (EL.Expressions.Create_Expression (Value, Context),
                                               Context);

   exception
      when E : others =>
         Log.Error ("Invalid parameter ", E, True);
         return EL.Expressions.Create_Expression ("", Context);

   end Get_Config;

   --  ------------------------------
   --  Send the event to the module
   --  ------------------------------
   procedure Send_Event (Plugin  : in Module;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Plugin.App.Send_Event (Content);
   end Send_Event;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_Module (Plugin : Module;
                         Name   : String) return Module_Access is
   begin
      if Plugin.Registry = null then
         return null;
      end if;
      return Find_By_Name (Plugin.Registry.all, Name);
   end Find_Module;

   --  ------------------------------
   --  Register under the given name a function to create the bean instance when
   --  it is accessed for a first time.  The scope defines the scope of the bean.
   --  bean
   --  ------------------------------
   procedure Register (Plugin : in out Module;
                       Name    : in String;
                       Bind    : in ASF.Beans.Class_Binding_Access) is
   begin
      Plugin.App.Register_Class (Name, Bind);
   end Register;

   --  ------------------------------
   --  Finalize the module.
   --  ------------------------------
   overriding
   procedure Finalize (Plugin : in out Module) is
   begin
      null;
   end Finalize;

   procedure Initialize (Manager : in out Module_Manager;
                         Module  : in AWA.Modules.Module'Class) is
   begin
      Manager.Module := Module.Self;
   end Initialize;

   function Get_Value (Manager : in Module_Manager;
                       Name    : in String) return Util.Beans.Objects.Object is
      pragma Unreferenced (Manager, Name);
   begin
      return Util.Beans.Objects.Null_Object;
   end Get_Value;

   --  Module manager
   --
   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module_Manager)
                            return ADO.Sessions.Session is
   begin
      return Manager.Module.Get_Session;
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module_Manager)
                                   return ADO.Sessions.Master_Session is
   begin
      return Manager.Module.Get_Master_Session;
   end Get_Master_Session;

   --  ------------------------------
   --  Send the event to the module.  The module identified by To is
   --  found and the event is posted on its event channel.
   --  ------------------------------
   procedure Send_Event (Manager : in Module_Manager;
                         Content : in AWA.Events.Module_Event'Class) is
   begin
      Manager.Module.Send_Event (Content);
   end Send_Event;

   procedure Initialize (Plugin : in out Module;
                         App    : in Application_Access;
                         Props  : in ASF.Applications.Config) is
      pragma Unreferenced (Props);
   begin
      Plugin.Self := Plugin'Unchecked_Access;
      Plugin.App := App;
   end Initialize;

   --  ------------------------------
   --  Initialize the registry
   --  ------------------------------
   procedure Initialize (Registry : in out Module_Registry;
                         Config   : in ASF.Applications.Config) is
   begin
      Registry.Config := Config;
   end Initialize;

   --  ------------------------------
   --  Register the module in the registry.
   --  ------------------------------
   procedure Register (Registry : in Module_Registry_Access;
                       App      : in Application_Access;
                       Plugin   : in Module_Access;
                       Name     : in String;
                       URI      : in String) is
      procedure Copy (Params : in Util.Properties.Manager'Class);

      procedure Copy (Params : in Util.Properties.Manager'Class) is
      begin
         Plugin.Config.Copy (From => Params, Prefix => Name & ".", Strip => True);
      end Copy;

      Paths : constant String := Registry.Config.Get (Applications.P_Module_Dir.P);
   begin
      Log.Info ("Register module '{0}' under URI '{1}'", Name, URI);

      if Plugin.Registry /= null then
         Log.Error ("Module '{0}' is already attached to a registry", Name);

         raise Program_Error with "Module '" & Name & "' already registered";
      end if;
      Plugin.App      := App;
      Plugin.Registry := Registry;
      Plugin.Name     := To_Unbounded_String (Name);
      Plugin.URI      := To_Unbounded_String (URI);
      Plugin.Registry.Name_Map.Insert (Name, Plugin);
      if URI /= "" then
         Plugin.Registry.URI_Map.Insert (URI, Plugin);
      end if;

      --  Load the module configuration file
      Log.Debug ("Module search path: {0}", Paths);
      declare
         Base  : constant String := Name & ".properties";
         Path  : constant String := Util.Files.Find_File_Path (Base, Paths);
      begin
         Plugin.Config.Load_Properties (Path => Path, Prefix => Name & ".", Strip => True);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Info ("Module configuration file '{0}' does not exist", Path);
      end;

      Plugin.Initialize (App, Plugin.Config);

      --  Read the module XML configuration file if there is one.
      declare
         Base : constant String := Plugin.Config.Get ("config", Name & ".xml");
         Path : constant String := Util.Files.Find_File_Path (Base, Paths);
         Ctx  : aliased EL.Contexts.Default.Default_Context;
      begin
         AWA.Modules.Reader.Read_Configuration (Plugin.all, Path, Ctx'Unchecked_Access);

      exception
         when Ada.IO_Exceptions.Name_Error =>
            Log.Warn ("Module configuration file '{0}' does not exist", Path);
      end;

      --  Override the module configuration with the application configuration
      App.Get_Init_Parameters (Copy'Access);

      Plugin.Configure (Plugin.Config);

   exception
      when Constraint_Error =>
         Log.Error ("Another module is already registered "
                    & "under name '{0}' or URI '{1}'", Name, URI);
         raise;
   end Register;

   --  ------------------------------
   --  Find the module with the given name
   --  ------------------------------
   function Find_By_Name (Registry : Module_Registry;
                          Name     : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.Name_Map, Name);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_Name;

   --  ------------------------------
   --  Find the module mapped to a given URI
   --  ------------------------------
   function Find_By_URI (Registry : Module_Registry;
                         URI      : String) return Module_Access is
      Pos : constant Module_Maps.Cursor := Module_Maps.Find (Registry.URI_Map, URI);
   begin
      if Module_Maps.Has_Element (Pos) then
         return Module_Maps.Element (Pos);
      end if;
      return null;
   end Find_By_URI;

   --  ------------------------------
   --  Iterate over the modules that have been registered and execute the Process
   --  procedure on each of the module instance.
   --  ------------------------------
   procedure Iterate (Registry : in Module_Registry;
                      Process  : access procedure (Plugin : in out Module'Class)) is
      Iter : Module_Maps.Cursor := Registry.Name_Map.First;
   begin
      while Module_Maps.Has_Element (Iter) loop
         Process (Module_Maps.Element (Iter).all);
         Module_Maps.Next (Iter);
      end loop;
   end Iterate;

   --  ------------------------------
   --  Get the database connection for reading
   --  ------------------------------
   function Get_Session (Manager : Module)
                            return ADO.Sessions.Session is
      Ctx : constant ASC.Service_Context_Access := ASC.Current;
   begin
      return ASC.Get_Session (Ctx);
   end Get_Session;

   --  ------------------------------
   --  Get the database connection for writing
   --  ------------------------------
   function Get_Master_Session (Manager : Module)
                                return ADO.Sessions.Master_Session is
      Ctx : constant ASC.Service_Context_Access := ASC.Current;
   begin
      return ASC.Get_Master_Session (Ctx);
   end Get_Master_Session;

   --  ------------------------------
   --  Add a listener to the module listner list.  The module will invoke the listner
   --  depending on events or actions that occur in the module.
   --  ------------------------------
   procedure Add_Listener (Into : in out Module;
                           Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Add_Listener (Into.Listeners, Item);
   end Add_Listener;

   --  ------------------------------
   --  Find the module with the given name in the application and add the listener to the
   --  module listener list.
   --  ------------------------------
   procedure Add_Listener (Plugin : in Module;
                           Name   : in String;
                           Item   : in Util.Listeners.Listener_Access) is
      M : constant Module_Access := Plugin.App.Find_Module (Name);
   begin
      if M = null then
         Log.Error ("Cannot find module {0} to add a lifecycle listener", Name);
      else
         M.Add_Listener (Item);
      end if;
   end Add_Listener;

   --  ------------------------------
   --  Remove a listener from the module listener list.
   --  ------------------------------
   procedure Remove_Listener (Into : in out Module;
                              Item : in Util.Listeners.Listener_Access) is
   begin
      Util.Listeners.Remove_Listener (Into.Listeners, Item);
   end Remove_Listener;

   --  Get per request manager => look in Request
   --  Get per session manager => look in Request.Get_Session
   --  Get per application manager => look in Application
   --  Get per pool manager => look in pool attached to Application
   function Get_Manager return Manager_Type_Access is

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class);

      Value : Util.Beans.Objects.Object;

      procedure Process (Request  : in out ASF.Requests.Request'Class;
                         Response : in out ASF.Responses.Response'Class) is
         pragma Unreferenced (Response);
      begin
         Value := Request.Get_Attribute (Name);
         if Util.Beans.Objects.Is_Null (Value) then
            declare
               M : constant Manager_Type_Access := new Manager_Type;
            begin
               Value := Util.Beans.Objects.To_Object (M.all'Unchecked_Access);
               Request.Set_Attribute (Name, Value);
            end;
         end if;
      end Process;

   begin
      ASF.Server.Update_Context (Process'Access);
      if Util.Beans.Objects.Is_Null (Value) then
         return null;
      end if;
      declare
         B : constant access Util.Beans.Basic.Readonly_Bean'Class
           := Util.Beans.Objects.To_Bean (Value);
      begin
         if not (B.all in Manager_Type'Class) then
            return null;
         end if;
         return Manager_Type'Class (B.all)'Unchecked_Access;
      end;
   end Get_Manager;

end AWA.Modules;

Update Get_Session and Get_Master_Session to get the database session by using the service context


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

with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Ptr;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   --  Memory allocation objects are stored in an AVL tree sorted
   --  on the memory slot address.
--
   subtype Allocation_Map is Allocation_Maps.Map;
   subtype Allocation_Cursor is Allocation_Maps.Cursor;
--
--     subtype Allocation_Ref is Allocation_AVL.Iterator;
--     --  Type representing a reference to a memory allocation slot.
--
--     use Allocation_AVL;
--     package Allocation_Ref_Containers is new BC.Containers (Allocation_Ref);
--     package Allocation_Ref_Trees is new Allocation_Ref_Containers.Trees;
--     package Allocation_Ref_AVL is
--       new Allocation_Ref_Trees.AVL (Key => Target_Addr,
--                                     Storage => Global_Heap.Storage);
--     --  Tree of references to memory allocation objects.
--
--     subtype Allocation_Ref_Map is Allocation_Ref_AVL.AVL_Tree;
--     subtype Allocation_Ref_Ref is Allocation_Ref_AVL.Iterator;

private

end MAT.Memory;

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

with MAT.Types;
with MAT.Frames;

with Interfaces;
package MAT.Memory is

   type Allocation is record
      Size   : MAT.Types.Target_Size;
      Frame  : Frames.Frame_Type;
      Time   : MAT.Types.Target_Tick_Ref;
      Thread : MAT.Types.Target_Thread_Ref;
   end record;

   use type MAT.Types.Target_Addr;
   package Allocation_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Addr,
                                      Element_Type => Allocation);

   --  Memory allocation objects are stored in an AVL tree sorted
   --  on the memory slot address.
--
   subtype Allocation_Map is Allocation_Maps.Map;
   subtype Allocation_Cursor is Allocation_Maps.Cursor;
--
--     subtype Allocation_Ref is Allocation_AVL.Iterator;
--     --  Type representing a reference to a memory allocation slot.
--
--     use Allocation_AVL;
--     package Allocation_Ref_Containers is new BC.Containers (Allocation_Ref);
--     package Allocation_Ref_Trees is new Allocation_Ref_Containers.Trees;
--     package Allocation_Ref_AVL is
--       new Allocation_Ref_Trees.AVL (Key => Target_Addr,
--                                     Storage => Global_Heap.Storage);
--     --  Tree of references to memory allocation objects.
--
--     subtype Allocation_Ref_Map is Allocation_Ref_AVL.AVL_Tree;
--     subtype Allocation_Ref_Ref is Allocation_Ref_AVL.Iterator;

private

end MAT.Memory;

Use Frame_Type type

Use Frame_Type type


-----------------------------------------------------------------------
--  wiki-render -- Wiki renderer
--  Copyright (C) 2015, 2016 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 Wiki.Render is

   --  ------------------------------
   --  Get the image link that must be rendered from the wiki image link.
   --  ------------------------------
   overriding
   procedure Make_Image_Link (Renderer : in Default_Link_Renderer;
                              Link     : in Wide_Wide_String;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural) is
      pragma Unreferenced (Renderer);
   begin
      URI    := To_Unbounded_Wide_Wide_String (Link);
      Width  := 0;
      Height := 0;
   end Make_Image_Link;

   --  ------------------------------
   --  Get the page link that must be rendered from the wiki page link.
   --  ------------------------------
   overriding
   procedure Make_Page_Link (Renderer : in Default_Link_Renderer;
                             Link     : in Wide_Wide_String;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean) is
      pragma Unreferenced (Renderer);
   begin
      URI    := To_Unbounded_Wide_Wide_String (Link);
      Exists := True;
   end Make_Page_Link;

   --  ------------------------------
   --  Render the list of nodes from the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document;
                     List   : in Wiki.Nodes.Node_List_Access) is
      use type Wiki.Nodes.Node_List_Access;

      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;

   begin
      if List /= null then
         Wiki.Nodes.Iterate (List, Process'Access);
      end if;
   end Render;

   --  ------------------------------
   --  Render the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document) is
      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;
   begin
      Doc.Iterate (Process'Access);
      Engine.Finish;
   end Render;

end Wiki.Render;

-----------------------------------------------------------------------
--  wiki-render -- Wiki renderer
--  Copyright (C) 2015, 2016 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 Wiki.Render is

   --  ------------------------------
   --  Get the image link that must be rendered from the wiki image link.
   --  ------------------------------
   overriding
   procedure Make_Image_Link (Renderer : in Default_Link_Renderer;
                              Link     : in Wide_Wide_String;
                              URI      : out Unbounded_Wide_Wide_String;
                              Width    : out Natural;
                              Height   : out Natural) is
      pragma Unreferenced (Renderer);
   begin
      URI    := To_Unbounded_Wide_Wide_String (Link);
      Width  := 0;
      Height := 0;
   end Make_Image_Link;

   --  ------------------------------
   --  Get the page link that must be rendered from the wiki page link.
   --  ------------------------------
   overriding
   procedure Make_Page_Link (Renderer : in Default_Link_Renderer;
                             Link     : in Wide_Wide_String;
                             URI      : out Unbounded_Wide_Wide_String;
                             Exists   : out Boolean) is
      pragma Unreferenced (Renderer);
   begin
      URI    := To_Unbounded_Wide_Wide_String (Link);
      Exists := True;
   end Make_Page_Link;

   --  ------------------------------
   --  Render the list of nodes from the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document;
                     List   : in Wiki.Nodes.Node_List_Access) is
      use type Wiki.Nodes.Node_List_Access;

      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;

   begin
      if List /= null then
         Wiki.Nodes.Iterate (List, Process'Access);
      end if;
   end Render;

   --  ------------------------------
   --  Render the document.
   --  ------------------------------
   procedure Render (Engine : in out Renderer'Class;
                     Doc    : in Wiki.Documents.Document) is
      procedure Process (Node : in Wiki.Nodes.Node_Type);

      procedure Process (Node : in Wiki.Nodes.Node_Type) is
      begin
         Engine.Render (Doc, Node);
      end Process;
   begin
      Doc.Iterate (Process'Access);
      Engine.Finish (Doc);
   end Render;

end Wiki.Render;

Add the document to the Finish procedure