-----------------------------------------------------------------------
--  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 & ".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 & ".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) = "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;
         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 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 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 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 & ".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) = "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 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;

Implement the Test_Http_Patch and register the test for execution


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

with ASF.Applications;
with ASF.Components.Html;
with ASF.Contexts.Faces;
package ASF.Components.Widgets.Likes is

   --  ------------------------------
   --  UILike
   --  ------------------------------
   --  The <b>UILike</b> component displays a social like button to recommend a page.
   type UILike is new ASF.Components.Html.UIHtmlComponent with null record;

   --  Get the link to submit in the like action.
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String;

   --  Render the like button for Facebook or Google+.
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  ------------------------------
   --  Like Generator
   --  ------------------------------
   --  The <tt>Like_Generator</tt> represents the specific method for the generation of
   --  a social like generator.  A generator is registered under a given name with the
   --  <tt>Register_Like</tt> operation.  The current implementation provides a Facebook
   --  like generator.
   type Like_Generator is limited interface;
   type Like_Generator_Access is access all Like_Generator'Class;

   --  Render the like button according to the generator and the component attributes.
   procedure Render_Like (Generator : in Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is abstract;

   --  Maximum number of generators that can be registered.
   MAX_LIKE_GENERATOR : constant Positive := 5;

   --  Register the like generator under the given name.
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access);

   --  ------------------------------
   --  Facebook like generator
   --  ------------------------------
   type Facebook_Like_Generator is new Like_Generator with null record;

   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  The application configuration parameter that defines which Facebook client ID must be used.
   package P_Facebook_App_Id is
     new ASF.Applications.Parameter ("facebook.client_id", "");

   --  ------------------------------
   --  Google like generator
   --  ------------------------------
   type Google_Like_Generator is new Like_Generator with null record;

   overriding
   procedure Render_Like (Generator : in Google_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  ------------------------------
   --  Twitter like generator
   --  ------------------------------
   type Twitter_Like_Generator is new Like_Generator with null record;

   overriding
   procedure Render_Like (Generator : in Twitter_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class);

end ASF.Components.Widgets.Likes;

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

with ASF.Applications;
with ASF.Components.Html;
with ASF.Contexts.Faces;
package ASF.Components.Widgets.Likes is

   --  ------------------------------
   --  UILike
   --  ------------------------------
   --  The <b>UILike</b> component displays a social like button to recommend a page.
   type UILike is new ASF.Components.Html.UIHtmlComponent with null record;

   --  Get the link to submit in the like action.
   function Get_Link (UI      : in UILike;
                      Context : in ASF.Contexts.Faces.Faces_Context'Class) return String;

   --  Render the like button for Facebook or Google+.
   overriding
   procedure Encode_Begin (UI      : in UILike;
                           Context : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  ------------------------------
   --  Like Generator
   --  ------------------------------
   --  The <tt>Like_Generator</tt> represents the specific method for the generation of
   --  a social like generator.  A generator is registered under a given name with the
   --  <tt>Register_Like</tt> operation.  The current implementation provides a Facebook
   --  like generator.
   type Like_Generator is limited interface;
   type Like_Generator_Access is access all Like_Generator'Class;

   --  Render the like button according to the generator and the component attributes.
   procedure Render_Like (Generator : in Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class) is abstract;

   --  Maximum number of generators that can be registered.
   MAX_LIKE_GENERATOR : constant Positive := 5;

   --  Register the like generator under the given name.
   procedure Register_Like (Name      : in Util.Strings.Name_Access;
                            Generator : in Like_Generator_Access);

   --  ------------------------------
   --  Facebook like generator
   --  ------------------------------
   type Facebook_Like_Generator is new Like_Generator with null record;

   overriding
   procedure Render_Like (Generator : in Facebook_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class);

   --  The application configuration parameter that defines which Facebook client ID must be used.
   package P_Facebook_App_Id is
     new ASF.Applications.Parameter ("facebook.client_id", "");

   --  ------------------------------
   --  Twitter like generator
   --  ------------------------------
   type Twitter_Like_Generator is new Like_Generator with null record;

   overriding
   procedure Render_Like (Generator : in Twitter_Like_Generator;
                          UI        : in UILike'Class;
                          Href      : in String;
                          Context   : in out ASF.Contexts.Faces.Faces_Context'Class);

end ASF.Components.Widgets.Likes;

Remove Google+ like because it does not exist anymore


-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  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 Ada.Containers.Vectors;

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   type Event_Type is mod 16;
   type Probe_Index_Type is mod 16;

   type Probe_Event_Type is record
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Time;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

private

   EVENT_BLOCK_SIZE : constant Positive := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Natural := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   protected type Event_Collector is

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
   end Event_Collector;

   type Target_Events is tagged limited record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

end MAT.Events.Targets;

-----------------------------------------------------------------------
--  mat-events-targets - Events received and collected from a target
--  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 Ada.Containers.Vectors;

with Util.Concurrent.Counters;

with MAT.Frames;
package MAT.Events.Targets is

   type Event_Type is mod 16;
   type Probe_Index_Type is mod 16;

   type Event_Id_Type is new Natural;

   type Probe_Event_Type is record
      Id       : Event_Id_Type;
      Event    : MAT.Types.Uint16;
      Index    : Probe_Index_Type;
      Time     : MAT.Types.Target_Time;
      Thread   : MAT.Types.Target_Thread_Ref;
      Frame    : MAT.Frames.Frame_Type;
      Addr     : MAT.Types.Target_Addr;
      Size     : MAT.Types.Target_Size;
      Old_Addr : MAT.Types.Target_Addr;
   end record;

   subtype Target_Event is Probe_Event_Type;

   package Target_Event_Vectors is
     new Ada.Containers.Vectors (Positive, Target_Event);

   subtype Target_Event_Vector is Target_Event_Vectors.Vector;
   subtype Target_Event_Cursor is Target_Event_Vectors.Cursor;

   type Target_Events is tagged limited private;
   type Target_Events_Access is access all Target_Events'Class;

   --  Add the event in the list of events and increment the event counter.
   procedure Insert (Target : in out Target_Events;
                     Event  : in Probe_Event_Type);

   procedure Get_Events (Target : in out Target_Events;
                         Start  : in MAT.Types.Target_Time;
                         Finish : in MAT.Types.Target_Time;
                         Into   : in out Target_Event_Vector);

   --  Get the start and finish time for the events that have been received.
   procedure Get_Time_Range (Target : in out Target_Events;
                             Start  : out MAT.Types.Target_Time;
                             Finish : out MAT.Types.Target_Time);

   --  Get the current event counter.
   function Get_Event_Counter (Target : in Target_Events) return Integer;

private

   EVENT_BLOCK_SIZE : constant Positive := 1024;

   type Probe_Event_Array is array (1 .. EVENT_BLOCK_SIZE) of Probe_Event_Type;

   type Event_Block is record
      Start  : MAT.Types.Target_Time;
      Finish : MAT.Types.Target_Time;
      Count  : Natural := 0;
      Events : Probe_Event_Array;
   end record;
   type Event_Block_Access is access all Event_Block;

   use type MAT.Types.Target_Time;
   package Event_Maps is
     new Ada.Containers.Ordered_Maps (Key_Type     => MAT.Types.Target_Time,
                                      Element_Type => Event_Block_Access);

   subtype Event_Map is Event_Maps.Map;
   subtype Event_Cursor is Event_Maps.Cursor;

   protected type Event_Collector is

      --  Add the event in the list of events.
      procedure Insert (Event  : in Probe_Event_Type);

      procedure Get_Events (Start  : in MAT.Types.Target_Time;
                            Finish : in MAT.Types.Target_Time;
                            Into   : in out Target_Event_Vector);

      --  Get the start and finish time for the events that have been received.
      procedure Get_Time_Range (Start  : out MAT.Types.Target_Time;
                                Finish : out MAT.Types.Target_Time);

   private
      Current       : Event_Block_Access := null;
      Events        : Event_Map;
      Last_Id       : Event_Id_Type := 0;
   end Event_Collector;

   type Target_Events is tagged limited record
      Events      : Event_Collector;
      Event_Count : Util.Concurrent.Counters.Counter;
   end record;

end MAT.Events.Targets;

Add a unique event id generated when the event is inserted


-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory events
--  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 MAT.Types; use MAT.Types;
package body MAT.Memory.Targets is

   procedure Create_Instance (Refs : in ClientInfo_Ref_Map) is
      --  Adapter : Manager       := Get_Manager (Refs);
      --  Client  : Client_Memory := new Client_Memory;
   begin
      --  Register_Client (Refs, "memory", Client.all'Access);
      --  Register_Servant (Adapter, Proxy);
      null;
   end Create_Instance;

end MAT.Memory.Targets;

-----------------------------------------------------------------------
--  Memory Events - Definition and Analysis of memory events
--  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 MAT.Types; use MAT.Types;
package body MAT.Memory.Targets is
--
--     procedure Create_Instance (Refs : in ClientInfo_Ref_Map) is
--        --  Adapter : Manager       := Get_Manager (Refs);
--        --  Client  : Client_Memory := new Client_Memory;
--     begin
--        --  Register_Client (Refs, "memory", Client.all'Access);
--        --  Register_Servant (Adapter, Proxy);
--        null;
--     end Create_Instance;
   procedure Init is
   begin
      null;
   end Init;

end MAT.Memory.Targets;

Comment old operation

Comment old operation


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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return "role";
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

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

with Util.Log.Loggers;
with Util.Serialize.Mappers.Record_Mapper;

with Security.Controllers;
with Security.Controllers.Roles;

package body Security.Policies.Roles is

   use Util.Log;

   --  The logger
   Log : constant Loggers.Logger := Loggers.Create ("Security.Policies.Roles");

   --  ------------------------------
   --  Get the policy name.
   --  ------------------------------
   overriding
   function Get_Name (From : in Role_Policy) return String is
      pragma Unreferenced (From);
   begin
      return "role";
   end Get_Name;

   --  ------------------------------
   --  Get the role name.
   --  ------------------------------
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      if Manager.Names (Role) = null then
         return "";
      else
         return Manager.Names (Role).all;
      end if;
   end Get_Role_Name;

   --  ------------------------------
   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   --  ------------------------------
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      Log.Debug ("Searching role {0}", Name);

      for I in Role_Type'First .. Manager.Next_Role loop
         exit when Manager.Names (I) = null;
         if Name = Manager.Names (I).all then
            return I;
         end if;
      end loop;

      Log.Debug ("Role {0} not found", Name);
      raise Invalid_Name;
   end Find_Role;

   --  ------------------------------
   --  Create a role
   --  ------------------------------
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type) is
   begin
      Role := Manager.Next_Role;
      Log.Info ("Role {0} is {1}", Name, Role_Type'Image (Role));

      if Manager.Next_Role = Role_Type'Last then
         Log.Error ("Too many roles allocated.  Number of roles is {0}",
                    Role_Type'Image (Role_Type'Last));
      else
         Manager.Next_Role := Manager.Next_Role + 1;
      end if;
      Manager.Names (Role) := new String '(Name);
   end Create_Role;

   --  ------------------------------
   --  Get or build a permission type for the given name.
   --  ------------------------------
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type) is
   begin
      Result := Manager.Find_Role (Name);

   exception
      when Invalid_Name =>
         Manager.Create_Role (Name, Result);
   end Add_Role_Type;

   type Config_Fields is (FIELD_NAME, FIELD_ROLE, FIELD_ROLE_PERMISSION, FIELD_ROLE_NAME);

   type Controller_Config_Access is access all Controller_Config;

   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object);

   --  ------------------------------
   --  Called while parsing the XML policy file when the <name>, <role> and <role-permission>
   --  XML entities are found.  Create the new permission when the complete permission definition
   --  has been parsed and save the permission in the security manager.
   --  ------------------------------
   procedure Set_Member (Into  : in out Controller_Config;
                         Field : in Config_Fields;
                         Value : in Util.Beans.Objects.Object) is
      use Security.Controllers.Roles;
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_ROLE =>
            declare
               Role : constant String := Util.Beans.Objects.To_String (Value);
            begin
               Into.Roles (Into.Count + 1) := Into.Manager.Find_Role (Role);
               Into.Count := Into.Count + 1;

            exception
               when Permissions.Invalid_Name =>
                  raise Util.Serialize.Mappers.Field_Error with "Invalid role: " & Role;
            end;

         when FIELD_ROLE_PERMISSION =>
            if Into.Count = 0 then
               raise Util.Serialize.Mappers.Field_Error with "Missing at least one role";
            end if;
            declare
               Name : constant String := Util.Beans.Objects.To_String (Into.Name);
               Perm : constant Role_Controller_Access
                 := new Role_Controller '(Count => Into.Count,
                                          Roles => Into.Roles (1 .. Into.Count));
            begin
               Into.Manager.Add_Permission (Name, Perm.all'Access);
               Into.Count := 0;
            end;

         when FIELD_ROLE_NAME =>
            declare
               Name : constant String := Util.Beans.Objects.To_String (Value);
               Role : Role_Type;
            begin
               Into.Manager.Add_Role_Type (Name, Role);
            end;
      end case;
   end Set_Member;

   package Config_Mapper is
     new Util.Serialize.Mappers.Record_Mapper (Element_Type        => Controller_Config,
                                               Element_Type_Access => Controller_Config_Access,
                                               Fields              => Config_Fields,
                                               Set_Member          => Set_Member);

   Mapper : aliased Config_Mapper.Mapper;

   --  ------------------------------
   --  Setup the XML parser to read the role-permission description.
   --  ------------------------------
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser) is
      Config : Controller_Config_Access := new Controller_Config;
   begin
      Reader.Add_Mapping ("policy-rules", Mapper'Access);
      Reader.Add_Mapping ("module", Mapper'Access);
      Config.Manager := Policy'Unchecked_Access;
      Config_Mapper.Set_Context (Reader, Config);
   end Prepare_Config;

   --  ------------------------------
   --  Finalize the policy manager.
   --  ------------------------------
   overriding
   procedure Finalize (Policy : in out Role_Policy) is
      use type Ada.Strings.Unbounded.String_Access;
   begin
      for I in Policy.Names'Range loop
         exit when Policy.Names (I) = null;
         Ada.Strings.Unbounded.Free (Policy.Names (I));
      end loop;
   end Finalize;

begin
   Mapper.Add_Mapping ("role-permission", FIELD_ROLE_PERMISSION);
   Mapper.Add_Mapping ("role-permission/name", FIELD_NAME);
   Mapper.Add_Mapping ("role-permission/role", FIELD_ROLE);
   Mapper.Add_Mapping ("security-role/role-name", FIELD_ROLE_NAME);
end Security.Policies.Roles;

Implement Finalize to cleanup the security policy


-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 2011, 2012, 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;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <policy-rules>
--      <security-role>
--        <role-name>admin</role-name>
--      </security-role>
--      <security-role>
--        <role-name>manager</role-name>
--      </security-role>
--      <role-permission>
--        <name>create-workspace</name>
--        <role>admin</role>
--        <role>manager</role>
--      </role-permission>
--      ...
--    </policy-rules>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   type Role_Name_Array is array (Positive range <>) of Ada.Strings.Unbounded.String_Access;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Get the number of roles set in the map.
   function Get_Count (Map : in Role_Map) return Natural;

   --  Return the list of role names separated by ','.
   function To_String (List : in Role_Name_Array) return String;

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

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

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Get the roles that grant the given permission.
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map;

   --  Get the list of role names that are defined by the role map.
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Reader : in out Util.Serialize.IO.XML.Parser);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   --  Array to map a permission index to a list of roles that are granted the permission.
   type Permission_Role_Array is array (Permission_Index) of Role_Map;

   type Role_Map_Name_Array is array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_Map_Name_Array := (others => null);
      Next_Role : Role_Type := Role_Type'First;
      Name      : Util.Beans.Objects.Object;
      Roles     : Role_Type_Array (1 .. Integer (Role_Type'Last)) := (others => 0);
      Count     : Natural := 0;

      --  The Grants array indicates for each permission the list of roles
      --  that are granted the permission.  This array allows a O(1) lookup.
      --  The implementation is limited to 256 permissions and 64 roles so this array uses 2K.
      --  The default is that no role is assigned to the permission.
      Grants    : Permission_Role_Array := (others => (others => False));
   end record;

end Security.Policies.Roles;

-----------------------------------------------------------------------
--  security-policies-roles -- Role based policies
--  Copyright (C) 2010, 2011, 2012, 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;

--  == Role Based Security Policy ==
--  The <tt>Security.Policies.Roles</tt> package implements a role based security policy.
--  In this policy, users are assigned one or several roles and permissions are
--  associated with roles.  A permission is granted if the user has one of the roles required
--  by the permission.
--
--  === Policy creation ===
--  An instance of the <tt>Role_Policy</tt> must be created and registered in the policy manager.
--  Get or declare the following variables:
--
--    Manager : Security.Policies.Policy_Manager;
--    Policy  : Security.Policies.Roles.Role_Policy_Access;
--
--  Create the role policy and register it in the policy manager as follows:
--
--    Policy := new Role_Policy;
--    Manager.Add_Policy (Policy.all'Access);
--
--  === Policy Configuration ===
--  A role is represented by a name in security configuration files.  A role based permission
--  is associated with a list of roles.  The permission is granted if the user has one of these
--  roles.  When the role based policy is registered in the policy manager, the following
--  XML configuration is used:
--
--    <policy-rules>
--      <security-role>
--        <role-name>admin</role-name>
--      </security-role>
--      <security-role>
--        <role-name>manager</role-name>
--      </security-role>
--      <role-permission>
--        <name>create-workspace</name>
--        <role>admin</role>
--        <role>manager</role>
--      </role-permission>
--      ...
--    </policy-rules>
--
--  This definition declares two roles: <tt>admin</tt> and <tt>manager</tt>
--  It defines a permission create-workspace that will be granted if the
--  user has either the admin or the manager role.
--
--  Each role is identified by a name in the configuration file.  It is represented by
--  a <tt>Role_Type</tt>.  To provide an efficient implementation, the <tt>Role_Type</tt>
--  is represented as an integer with a limit of 64 different roles.
--
--  === Assigning roles to users ===
--  A <tt>Security_Context</tt> must be associated with a set of roles before checking the
--  permission.  This is done by using the <tt>Set_Role_Context</tt> operation:
--
--     Security.Policies.Roles.Set_Role_Context (Security.Contexts.Current, "admin");
--
package Security.Policies.Roles is

   NAME : constant String := "Role-Policy";

   --  Each role is represented by a Role_Type number to provide a fast
   --  and efficient role check.
   type Role_Type is new Natural range 0 .. 63;
   for Role_Type'Size use 8;

   type Role_Type_Array is array (Positive range <>) of Role_Type;

   type Role_Name_Array is array (Positive range <>) of Ada.Strings.Unbounded.String_Access;

   --  The Role_Map represents a set of roles which are assigned to a user.
   --  Each role is represented by a boolean in the map.  The implementation is limited
   --  to 64 roles (the number of different permissions can be higher).
   type Role_Map is array (Role_Type'Range) of Boolean;
   pragma Pack (Role_Map);

   --  Get the number of roles set in the map.
   function Get_Count (Map : in Role_Map) return Natural;

   --  Return the list of role names separated by ','.
   function To_String (List : in Role_Name_Array) return String;

   --  ------------------------------
   --  Role principal context
   --  ------------------------------
   --  The <tt>Role_Principal_Context</tt> interface must be implemented by the user
   --  <tt>Principal</tt> to be able to use the role based policy.   The role based policy
   --  controller will first check that the <tt>Principal</tt> implements that interface.
   --  It uses the <tt>Get_Roles</tt> function to get the current roles assigned to the user.
   type Role_Principal_Context is limited interface;
   function Get_Roles (User : in Role_Principal_Context) return Role_Map is abstract;

   --  ------------------------------
   --  Policy context
   --  ------------------------------
   --  The Role_Policy_Context gives security context information that the role
   --  based policy can use to verify the permission.
   type Role_Policy_Context is new Policy_Context with record
      Roles : Role_Map;
   end record;
   type Role_Policy_Context_Access is access all Role_Policy_Context'Class;

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in Role_Map);

   --  Set the roles which are assigned to the user in the security context.
   --  The role policy will use these roles to verify a permission.
   procedure Set_Role_Context (Context : in out Security.Contexts.Security_Context'Class;
                               Roles   : in String);

   --  ------------------------------
   --  Role based policy
   --  ------------------------------
   type Role_Policy is new Policy with private;
   type Role_Policy_Access is access all Role_Policy'Class;

   Invalid_Name : exception;

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

   --  Find the role type associated with the role name identified by Name.
   --  Raises Invalid_Name if there is no role type.
   function Find_Role (Manager : in Role_Policy;
                       Name    : in String) return Role_Type;

   --  Get the role name.
   function Get_Role_Name (Manager : in Role_Policy;
                           Role    : in Role_Type) return String;

   --  Get the roles that grant the given permission.
   function Get_Grants (Manager    : in Role_Policy;
                        Permission : in Permissions.Permission_Index) return Role_Map;

   --  Get the list of role names that are defined by the role map.
   function Get_Role_Names (Manager : in Role_Policy;
                            Map     : in Role_Map) return Role_Name_Array;

   --  Create a role
   procedure Create_Role (Manager : in out Role_Policy;
                          Name    : in String;
                          Role    : out Role_Type);

   --  Get or add a role type for the given name.
   procedure Add_Role_Type (Manager   : in out Role_Policy;
                            Name      : in String;
                            Result    : out Role_Type);

   --  Set the roles specified in the <tt>Roles</tt> parameter.  Each role is represented by
   --  its name and multiple roles are separated by ','.
   --  Raises Invalid_Name if a role was not found.
   procedure Set_Roles (Manager : in Role_Policy;
                        Roles   : in String;
                        Into    : out Role_Map);

   --  Setup the XML parser to read the role-permission description.
   overriding
   procedure Prepare_Config (Policy : in out Role_Policy;
                             Mapper : in out Util.Serialize.Mappers.Processing);

   --  Finalize the policy manager.
   overriding
   procedure Finalize (Policy : in out Role_Policy);

   --  Get the role policy associated with the given policy manager.
   --  Returns the role policy instance or null if it was not registered in the policy manager.
   function Get_Role_Policy (Manager : in Security.Policies.Policy_Manager'Class)
                             return Role_Policy_Access;

private

   --  Array to map a permission index to a list of roles that are granted the permission.
   type Permission_Role_Array is array (Permission_Index) of Role_Map;

   type Role_Map_Name_Array is array (Role_Type'Range) of Ada.Strings.Unbounded.String_Access;

   type Role_Policy is new Policy with record
      Names     : Role_Map_Name_Array := (others => null);
      Next_Role : Role_Type := Role_Type'First;
      Name      : Util.Beans.Objects.Object;
      Roles     : Role_Type_Array (1 .. Integer (Role_Type'Last)) := (others => 0);
      Count     : Natural := 0;

      --  The Grants array indicates for each permission the list of roles
      --  that are granted the permission.  This array allows a O(1) lookup.
      --  The implementation is limited to 256 permissions and 64 roles so this array uses 2K.
      --  The default is that no role is assigned to the permission.
      Grants    : Permission_Role_Array := (others => (others => False));
   end record;

end Security.Policies.Roles;

Change the Mapper parameter to use the Mappers.Processing type


-----------------------------------------------------------------------
--  awa-storages-servlets -- Serve files saved in the storage service
--  Copyright (C) 2012, 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.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;

with Util.Log.Loggers;

with ADO.Objects;

with ASF.Streams;

with AWA.Storages.Services;
with AWA.Storages.Modules;
package body AWA.Storages.Servlets is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Storages.Servlets");

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   overriding
   procedure Initialize (Server  : in out Storage_Servlet;
                         Context : in Servlet.Core.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Storage_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      Data    : ADO.Blob_Ref;
      Mime    : Ada.Strings.Unbounded.Unbounded_String;
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Date    : Ada.Calendar.Time;
   begin
      Storage_Servlet'Class (Server).Load (Request, Name, Mime, Date, Data);
      if Data.Is_Null then
         Log.Info ("Storage file {0} not found", Request.Get_Request_URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;

      --  Send the file.
      Response.Set_Content_Type (Ada.Strings.Unbounded.To_String (Mime));
      if Ada.Strings.Unbounded.Length (Name) > 0 then
         Response.Add_Header ("Content-Disposition",
                              "attachment; filename=" & Ada.Strings.Unbounded.To_String (Name));
      end if;
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
      begin
         Output.Write (Data.Value.Data);
      end;

   exception
      when ADO.Objects.NOT_FOUND | Constraint_Error =>
         Log.Info ("Storage file {0} not found", Request.Get_Request_URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
   end Do_Get;

   --  ------------------------------
   --  Load the data content that correspond to the GET request and get the name as well
   --  as mime-type and date.
   --  ------------------------------
   procedure Load (Server   : in Storage_Servlet;
                   Request  : in out ASF.Requests.Request'Class;
                   Name     : out Ada.Strings.Unbounded.Unbounded_String;
                   Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                   Date     : out Ada.Calendar.Time;
                   Data     : out ADO.Blob_Ref) is
      pragma Unreferenced (Server);

      Store   : constant String := Request.Get_Path_Parameter (1);
      Manager : constant Services.Storage_Service_Access := Storages.Modules.Get_Storage_Manager;
      Id      : ADO.Identifier;
   begin
      if Store'Length = 0 then
         Log.Info ("Invalid storage URI: {0}", Store);
         return;
      end if;

      --  Extract the storage identifier from the URI.
      Id := ADO.Identifier'Value (Store);

      Log.Info ("GET storage file {0}", Store);
      Manager.Load (From => Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
   end Load;

end AWA.Storages.Servlets;

-----------------------------------------------------------------------
--  awa-storages-servlets -- Serve files saved in the storage service
--  Copyright (C) 2012, 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.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;

with Util.Log.Loggers;

with ADO.Objects;

with ASF.Streams;

with AWA.Storages.Services;
with AWA.Storages.Modules;
package body AWA.Storages.Servlets is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("AWA.Storages.Servlets");

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   overriding
   procedure Initialize (Server  : in out Storage_Servlet;
                         Context : in Servlet.Core.Servlet_Registry'Class) is
   begin
      null;
   end Initialize;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   overriding
   procedure Do_Get (Server   : in Storage_Servlet;
                     Request  : in out ASF.Requests.Request'Class;
                     Response : in out ASF.Responses.Response'Class) is
      URI     : constant String := Request.Get_Request_URI;
      Data    : ADO.Blob_Ref;
      Mime    : Ada.Strings.Unbounded.Unbounded_String;
      Name    : Ada.Strings.Unbounded.Unbounded_String;
      Date    : Ada.Calendar.Time;
   begin
      Storage_Servlet'Class (Server).Load (Request, Name, Mime, Date, Data);
      if Data.Is_Null then
         Log.Info ("GET: {0}: storage file not found", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      Log.Info ("GET: {0}", URI);

      --  Send the file.
      Response.Set_Content_Type (Ada.Strings.Unbounded.To_String (Mime));
      if Ada.Strings.Unbounded.Length (Name) > 0 then
         Response.Add_Header ("Content-Disposition",
                              "attachment; filename=" & Ada.Strings.Unbounded.To_String (Name));
      end if;
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
      begin
         Output.Write (Data.Value.Data);
      end;

   exception
      when ADO.Objects.NOT_FOUND | Constraint_Error =>
         Log.Info ("GET: {0}: Storage file not found", URI);
         Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         return;
   end Do_Get;

   --  ------------------------------
   --  Load the data content that correspond to the GET request and get the name as well
   --  as mime-type and date.
   --  ------------------------------
   procedure Load (Server   : in Storage_Servlet;
                   Request  : in out ASF.Requests.Request'Class;
                   Name     : out Ada.Strings.Unbounded.Unbounded_String;
                   Mime     : out Ada.Strings.Unbounded.Unbounded_String;
                   Date     : out Ada.Calendar.Time;
                   Data     : out ADO.Blob_Ref) is
      pragma Unreferenced (Server);

      Store   : constant String := Request.Get_Path_Parameter (1);
      Manager : constant Services.Storage_Service_Access := Storages.Modules.Get_Storage_Manager;
      Id      : ADO.Identifier;
   begin
      if Store'Length = 0 then
         Log.Info ("Invalid storage URI: {0}", Store);
         return;
      end if;

      --  Extract the storage identifier from the URI.
      Id := ADO.Identifier'Value (Store);

      Log.Info ("GET storage file {0}", Store);
      Manager.Load (From => Id, Name => Name, Mime => Mime, Date => Date, Into => Data);
   end Load;

end AWA.Storages.Servlets;

Add some log message to help in debugging