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

with Util.Files;
with Util.Strings;
with Util.Streams;
with Util.Streams.Files;
with Ada.Streams;
with Ada.Streams.Stream_IO;

with Ada.Directories;

with ASF.Streams;
package body ASF.Servlets.Files is

   use Ada.Streams;
   use Ada.Streams.Stream_IO;
   use Ada.Directories;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out File_Servlet;
                         Context : in Servlet_Registry'Class) is
      Dir      : constant String := Context.Get_Init_Parameter ("web.dir");
      Def_Type : constant String := Context.Get_Init_Parameter ("content-type.default");
   begin
      Server.Dir := new String '(Dir);
      Server.Default_Content_Type := new String '(Def_Type);
   end Initialize;

   --  ------------------------------
   --  Returns the time the Request object was last modified, in milliseconds since
   --  midnight January 1, 1970 GMT.  If the time is unknown, this method returns
   --  a negative number (the default).
   --
   --  Servlets that support HTTP GET requests and can quickly determine their
   --  last modification time should override this method. This makes browser and
   --  proxy caches work more effectively, reducing the load on server and network
   --  resources.
   --  ------------------------------
   function Get_Last_Modified (Server  : in File_Servlet;
                               Request : in Requests.Request'Class)
                               return Ada.Calendar.Time is
      pragma Unreferenced (Server, Request);
   begin
      return Ada.Calendar.Clock;
   end Get_Last_Modified;

   --  ------------------------------
   --  Set the content type associated with the given file
   --  ------------------------------
   procedure Set_Content_Type (Server   : in File_Servlet;
                               Path     : in String;
                               Response : in out Responses.Response'Class) is
      Pos : constant Natural := Util.Strings.Rindex (Path, '.');
   begin
      if Pos = 0 then
         Response.Set_Content_Type (Server.Default_Content_Type.all);
         return;
      end if;
      if Path (Pos .. Path'Last) = ".css" then
         Response.Set_Content_Type ("text/css");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".js" then
         Response.Set_Content_Type ("text/javascript");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".html" then
         Response.Set_Content_Type ("text/html");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".txt" then
         Response.Set_Content_Type ("text/plain");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".png" then
         Response.Set_Content_Type ("image/png");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".jpg" then
         Response.Set_Content_Type ("image/jpg");
         return;
      end if;
   end Set_Content_Type;

   --  ------------------------------
   --  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"
   --  ------------------------------
   procedure Do_Get (Server   : in File_Servlet;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is

      use Util.Files;

      URI  : constant String := Request.Get_Path_Info;
      Path : constant String := Find_File_Path (Name => URI, Paths => Server.Dir.all);
   begin
      if not Ada.Directories.Exists (Path)
        or else Ada.Directories.Kind (Path) /= Ada.Directories.Ordinary_File then
         Response.Send_Error (Responses.SC_NOT_FOUND);
         return;
      end if;

      File_Servlet'Class (Server).Set_Content_Type (Path, Response);
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Input  : Util.Streams.Files.File_Stream;
      begin
         Input.Open (Name => Path, Mode => In_File);
         Util.Streams.Copy (From => Input, Into => Output);
      end;
   end Do_Get;

end ASF.Servlets.Files;

-----------------------------------------------------------------------
--  asf.servlets.files -- Static file servlet
--  Copyright (C) 2010, 2011, 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.Files;
with Util.Strings;
with Util.Streams;
with Util.Streams.Files;
with Ada.Streams;
with Ada.Streams.Stream_IO;

with Ada.Directories;

with ASF.Streams;
with ASF.Applications;
package body ASF.Servlets.Files is

   use Ada.Streams;
   use Ada.Streams.Stream_IO;
   use Ada.Directories;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out File_Servlet;
                         Context : in Servlet_Registry'Class) is
      Dir      : constant String := Context.Get_Init_Parameter (ASF.Applications.VIEW_DIR);
      Def_Type : constant String := Context.Get_Init_Parameter ("content-type.default");
   begin
      Server.Dir := new String '(Dir);
      Server.Default_Content_Type := new String '(Def_Type);
   end Initialize;

   --  ------------------------------
   --  Returns the time the Request object was last modified, in milliseconds since
   --  midnight January 1, 1970 GMT.  If the time is unknown, this method returns
   --  a negative number (the default).
   --
   --  Servlets that support HTTP GET requests and can quickly determine their
   --  last modification time should override this method. This makes browser and
   --  proxy caches work more effectively, reducing the load on server and network
   --  resources.
   --  ------------------------------
   function Get_Last_Modified (Server  : in File_Servlet;
                               Request : in Requests.Request'Class)
                               return Ada.Calendar.Time is
      pragma Unreferenced (Server, Request);
   begin
      return Ada.Calendar.Clock;
   end Get_Last_Modified;

   --  ------------------------------
   --  Set the content type associated with the given file
   --  ------------------------------
   procedure Set_Content_Type (Server   : in File_Servlet;
                               Path     : in String;
                               Response : in out Responses.Response'Class) is
      Pos : constant Natural := Util.Strings.Rindex (Path, '.');
   begin
      if Pos = 0 then
         Response.Set_Content_Type (Server.Default_Content_Type.all);
         return;
      end if;
      if Path (Pos .. Path'Last) = ".css" then
         Response.Set_Content_Type ("text/css");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".js" then
         Response.Set_Content_Type ("text/javascript");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".html" then
         Response.Set_Content_Type ("text/html");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".txt" then
         Response.Set_Content_Type ("text/plain");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".png" then
         Response.Set_Content_Type ("image/png");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".jpg" then
         Response.Set_Content_Type ("image/jpg");
         return;
      end if;
   end Set_Content_Type;

   --  ------------------------------
   --  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"
   --  ------------------------------
   procedure Do_Get (Server   : in File_Servlet;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is

      use Util.Files;

      URI  : constant String := Request.Get_Path_Info;
      Path : constant String := Find_File_Path (Name => URI, Paths => Server.Dir.all);
   begin
      if not Ada.Directories.Exists (Path)
        or else Ada.Directories.Kind (Path) /= Ada.Directories.Ordinary_File then
         Response.Send_Error (Responses.SC_NOT_FOUND);
         return;
      end if;

      File_Servlet'Class (Server).Set_Content_Type (Path, Response);
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Input  : Util.Streams.Files.File_Stream;
      begin
         Input.Open (Name => Path, Mode => In_File);
         Util.Streams.Copy (From => Input, Into => Output);
      end;
   end Do_Get;

end ASF.Servlets.Files;

Use the ASF.Applications.VIEW_DIR parameter to configure the root directory where static files are stored


------------------------------------------------------------------------------
--                                                                          --
--                  Copyright (C) 2015-2016, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This program demonstrates reading the VBat (battery voltage) value from
--  an ADC unit, using polling.

--  Note that you will likely need to reset the board manually after loading.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);
with Interfaces;   use Interfaces;

with STM32.Board;  use STM32.Board;
with STM32.Device; use STM32.Device;

with HAL;          use HAL;
with STM32.ADC;    use STM32.ADC;
with STM32.GPIO;   use STM32.GPIO;

with LCD_Std_Out; use LCD_Std_Out;

procedure Demo_ADC_VBat_Polling is

   Counts  : Word;
   Voltage : Word;  -- in millivolts

   Successful : Boolean;
   Timed_Out : exception;

   procedure Print (X, Y : Natural; Value : Word; Suffix : String := "");

   -----------
   -- Print --
   -----------

   procedure Print (X, Y : Natural; Value : Word; Suffix : String := "") is
      Value_Image : constant String := Value'Img;
   begin
      Put (X, Y, Value_Image (2 .. Value_Image'Last) & Suffix & "   ");
   end Print;

begin
   Initialize_LEDs;

   Put_Line ("Starting");

   Enable_Clock (VBat.ADC.all);

   Reset_All_ADC_Units;

   Configure_Common_Properties
     (Mode           => Independent,
      Prescalar      => PCLK2_Div_2,
      DMA_Mode       => Disabled,
      Sampling_Delay => Sampling_Delay_5_Cycles);

   Configure_Unit
     (VBat.ADC.all,
      Resolution => ADC_Resolution_12_Bits,
      Alignment  => Right_Aligned);

   Configure_Regular_Conversions
     (VBat.ADC.all,
      Continuous  => False,
      Trigger     => Software_Triggered,
      Enable_EOC  => True,
      Conversions => (1 => (VBat.Channel, Sample_Time => Sample_112_Cycles)));

   Enable (VBat.ADC.all);

   loop
      Start_Conversion (VBat.ADC.all);

      Poll_For_Status (VBat.ADC.all, Regular_Channel_Conversion_Complete, Successful);
      if not Successful then
         raise Timed_Out;
      end if;

      Counts := Word (Conversion_Value (VBat.ADC.all));

      Print (0, 0, Counts);

      Voltage := ((Counts * VBat_Bridge_Divisor) * ADC_Supply_Voltage) / 16#FFF#;
      --  16#FFF# because we are using 12-bit conversion resolution

      Print (0, 24, Voltage, "mv");

      Toggle (STM32.Board.Green);
   end loop;
end Demo_ADC_VBat_Polling;

------------------------------------------------------------------------------
--                                                                          --
--                  Copyright (C) 2015-2016, AdaCore                        --
--                                                                          --
--  Redistribution and use in source and binary forms, with or without      --
--  modification, are permitted provided that the following conditions are  --
--  met:                                                                    --
--     1. Redistributions of source code must retain the above copyright    --
--        notice, this list of conditions and the following disclaimer.     --
--     2. Redistributions in binary form must reproduce the above copyright --
--        notice, this list of conditions and the following disclaimer in   --
--        the documentation and/or other materials provided with the        --
--        distribution.                                                     --
--     3. Neither the name of STMicroelectronics nor the names of its       --
--        contributors may be used to endorse or promote products derived   --
--        from this software without specific prior written permission.     --
--                                                                          --
--   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS    --
--   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT      --
--   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR  --
--   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT   --
--   HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, --
--   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT       --
--   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,  --
--   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY  --
--   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT    --
--   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE  --
--   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.   --
--                                                                          --
------------------------------------------------------------------------------

--  This program demonstrates reading the VBat (battery voltage) value from
--  an ADC unit, using polling.

--  Note that you will likely need to reset the board manually after loading.

with Last_Chance_Handler;  pragma Unreferenced (Last_Chance_Handler);
with Interfaces;   use Interfaces;

with STM32.Board;  use STM32.Board;
with STM32.Device; use STM32.Device;

with HAL;          use HAL;
with STM32.ADC;    use STM32.ADC;
with STM32.GPIO;   use STM32.GPIO;

with LCD_Std_Out; use LCD_Std_Out;

procedure Demo_ADC_VBat_Polling is

   Counts  : Word;
   Voltage : Word;  -- in millivolts

   Successful : Boolean;
   Timed_Out : exception;

   procedure Print (X, Y : Natural; Value : Word; Suffix : String := "");

   -----------
   -- Print --
   -----------

   procedure Print (X, Y : Natural; Value : Word; Suffix : String := "") is
      Value_Image : constant String := Value'Img;
   begin
      Put (X, Y, Value_Image (2 .. Value_Image'Last) & Suffix & "   ");
   end Print;

begin
   Initialize_LEDs;

   Enable_Clock (VBat.ADC.all);

   Reset_All_ADC_Units;

   Configure_Common_Properties
     (Mode           => Independent,
      Prescalar      => PCLK2_Div_2,
      DMA_Mode       => Disabled,
      Sampling_Delay => Sampling_Delay_5_Cycles);

   Configure_Unit
     (VBat.ADC.all,
      Resolution => ADC_Resolution_12_Bits,
      Alignment  => Right_Aligned);

   Configure_Regular_Conversions
     (VBat.ADC.all,
      Continuous  => False,
      Trigger     => Software_Triggered,
      Enable_EOC  => True,
      Conversions => (1 => (VBat.Channel, Sample_Time => Sample_112_Cycles)));

   Enable (VBat.ADC.all);

   loop
      Start_Conversion (VBat.ADC.all);

      Poll_For_Status (VBat.ADC.all, Regular_Channel_Conversion_Complete, Successful);
      if not Successful then
         raise Timed_Out;
      end if;

      Counts := Word (Conversion_Value (VBat.ADC.all));

      Print (0, 0, Counts);

      Voltage := ((Counts * VBat_Bridge_Divisor) * ADC_Supply_Voltage) / 16#FFF#;
      --  16#FFF# because we are using 12-bit conversion resolution

      Print (0, 24, Voltage, "mv");

      Toggle (STM32.Board.Green);
   end loop;
end Demo_ADC_VBat_Polling;

remove vestigial Put_Line

remove vestigial Put_Line


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

with Util.Tests;

package Util.Files.Rolling.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the Format procedure with its pattern replacement.
   procedure Test_Format (T : in out Test);

   --  Test a rolling manager configured with ascending rolling mode.
   procedure Test_Rolling_Ascending (T : in out Test);

end Util.Files.Rolling.Tests;

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

with Util.Tests;

package Util.Files.Rolling.Tests is

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

   type Test is new Util.Tests.Test with null record;

   --  Test the Format procedure with its pattern replacement.
   procedure Test_Format (T : in out Test);

   --  Test a rolling manager configured with ascending rolling mode.
   procedure Test_Rolling_Ascending (T : in out Test);

   --  Test a rolling manager configured with descending rolling mode.
   procedure Test_Rolling_Descending (T : in out Test);

end Util.Files.Rolling.Tests;

Add Test_Rolling_Descending procedure

Add Test_Rolling_Descending procedure


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

--  The <b>ASF.Lifecycles.Response</b> package defines the behavior
--  of the response phase.
package body ASF.Lifecycles.Response is

   use Ada.Exceptions;
   use ASF.Applications;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Lifecycles.Response");

   --  ------------------------------
   --  Initialize the phase controller.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Response_Controller;
                         Views      : access ASF.Applications.Views.View_Handler'Class) is
   begin
      Controller.View_Handler := Views;
   end Initialize;

   --  ------------------------------
   --  Execute the restore view phase.
   --  ------------------------------
   overriding
   procedure Execute (Controller : in Response_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      View    : constant Components.Root.UIViewRoot := Context.Get_View_Root;
   begin
      if Components.Root.Get_Root (View) = null then
         Log.Warn ("Page not found: {0}", Context.Get_View_Name);
         Context.Get_Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         Context.Response_Completed;
      else
         Controller.View_Handler.Render_View (Context, View);
      end if;

   exception
      when E : others =>
         Log.Error ("Error when displaying view {0}: {1}: {2}", "?",
                    Exception_Name (E), Exception_Message (E));
         raise;
   end Execute;

end ASF.Lifecycles.Response;

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

--  The <b>ASF.Lifecycles.Response</b> package defines the behavior
--  of the response phase.
package body ASF.Lifecycles.Response is

   use Ada.Exceptions;

   --  The logger
   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("ASF.Lifecycles.Response");

   --  ------------------------------
   --  Initialize the phase controller.
   --  ------------------------------
   overriding
   procedure Initialize (Controller : in out Response_Controller;
                         Views      : access ASF.Applications.Views.View_Handler'Class) is
   begin
      Controller.View_Handler := Views;
   end Initialize;

   --  ------------------------------
   --  Execute the restore view phase.
   --  ------------------------------
   overriding
   procedure Execute (Controller : in Response_Controller;
                      Context    : in out ASF.Contexts.Faces.Faces_Context'Class) is
      View    : constant Components.Root.UIViewRoot := Context.Get_View_Root;
   begin
      if Components.Root.Get_Root (View) = null then
         Log.Warn ("Page not found: {0}", Context.Get_View_Name);
         Context.Get_Response.Send_Error (ASF.Responses.SC_NOT_FOUND);
         Context.Response_Completed;
      else
         Controller.View_Handler.Render_View (Context, View);
      end if;

   exception
      when E : others =>
         Log.Error ("Error when displaying view {0}: {1}: {2}", "?",
                    Exception_Name (E), Exception_Message (E));
         raise;
   end Execute;

end ASF.Lifecycles.Response;

Remove unused use clauses

Remove unused use clauses


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

with Ada.Finalization;

with Security.Permissions;
with Security.Policies;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--    * An instance of the security context is declared within a function/procedure as
--      a local variable
--
--    * This instance will be associated with the current thread through a task attribute
--
--    * The security context is populated with information to identify the current user,
--      his roles, permissions and other information that could be used by security controllers
--
--    * To verify a permission, the current security context is retrieved and the
--      Has_Permission operation is called,
--
--    * The Has_Permission will first look in a small cache stored in the security context.
--
--    * When not present in the cache, it will use the security manager to find the
--      security controller associated with the permission to verify
--
--    * The security controller will be called with the security context to check the permission.
--      The whole job of checking the permission is done by the security controller.
--      The security controller retrieves information from the security context to decide
--      whether the permission is granted or not.
--
--    * The result produced by the security controller is then saved in the local cache.
--
package Security.Contexts is

   Invalid_Context : exception;
   Invalid_Policy  : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

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

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission'Class;
                             Result     : out Boolean);

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

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

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

   --  Set a policy context information represented by Value and associated with
   --  the Policy.
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access);

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

   --  Returns True if a context information was registered for the security policy.
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

   type Permission_Cache is record
      Perm   : Security.Permissions.Permission_Type;
      Result : Boolean;
   end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Policies.Policy_Manager_Access := null;
      Principal   : Security.Principal_Access := null;
      Contexts    : Security.Policies.Policy_Context_Array_Access := null;
   end record;

end Security.Contexts;

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

with Ada.Finalization;

with Security.Permissions;
with Security.Policies;

--  == Security Context ==
--  The security context provides contextual information for a security controller to
--  verify that a permission is granted.
--  This security context is used as follows:
--
--    * An instance of the security context is declared within a function/procedure as
--      a local variable
--
--    * This instance will be associated with the current thread through a task attribute
--
--    * The security context is populated with information to identify the current user,
--      his roles, permissions and other information that could be used by security controllers
--
--    * To verify a permission, the current security context is retrieved and the
--      Has_Permission operation is called,
--
--    * The Has_Permission will first look in a small cache stored in the security context.
--
--    * When not present in the cache, it will use the security manager to find the
--      security controller associated with the permission to verify
--
--    * The security controller will be called with the security context to check the permission.
--      The whole job of checking the permission is done by the security controller.
--      The security controller retrieves information from the security context to decide
--      whether the permission is granted or not.
--
--    * The result produced by the security controller is then saved in the local cache.
--
package Security.Contexts is

   Invalid_Context : exception;
   Invalid_Policy  : exception;

   type Security_Context is new Ada.Finalization.Limited_Controlled with private;
   type Security_Context_Access is access all Security_Context'Class;

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

   --  Get the permission manager.
   function Get_Permission_Manager (Context : in Security_Context'Class)
                                    return Security.Policies.Policy_Manager_Access;
   pragma Inline_Always (Get_Permission_Manager);

   --  Get the policy with the name Name registered in the policy manager.
   --  Returns null if there is no such policy.
   function Get_Policy (Context : in Security_Context'Class;
                        Name    : in String) return Security.Policies.Policy_Access;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission_Index;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in String;
                             Result     : out Boolean);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   procedure Has_Permission (Context    : in out Security_Context;
                             Permission : in Security.Permissions.Permission'Class;
                             Result     : out Boolean);

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

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

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

   --  Set a policy context information represented by Value and associated with
   --  the Policy.
   procedure Set_Policy_Context (Context   : in out Security_Context;
                                 Policy    : in Security.Policies.Policy_Access;
                                 Value     : in Security.Policies.Policy_Context_Access);

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

   --  Returns True if a context information was registered for the security policy.
   function Has_Policy_Context (Context : in Security_Context;
                                Policy  : in Security.Policies.Policy_Access) return Boolean;

   --  Get the current security context.
   --  Returns null if the current thread is not associated with any security context.
   function Current return Security_Context_Access;
   pragma Inline_Always (Current);

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in Security.Permissions.Permission_Index) return Boolean;

   --  Check if the permission identified by Permission is allowed according to
   --  the current security context.  The result is cached in the security context and
   --  returned in Result.
   function Has_Permission (Permission : in String) return Boolean;

private

--     type Permission_Cache is record
--        Perm   : Security.Permissions.Permission_Type;
--        Result : Boolean;
--     end record;

   type Security_Context is new Ada.Finalization.Limited_Controlled with record
      Previous    : Security_Context_Access := null;
      Manager     : Security.Policies.Policy_Manager_Access := null;
      Principal   : Security.Principal_Access := null;
      Contexts    : Security.Policies.Policy_Context_Array_Access := null;
   end record;

end Security.Contexts;

Remove the Permission_Cache record

Remove the Permission_Cache record


-----------------------------------------------------------------------
--  awa-permissions-services -- Permissions controller
--  Copyright (C) 2011, 2012, 2013, 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 AWA.Applications;

with Util.Beans.Objects;

with EL.Functions;

with ADO;
with ADO.Sessions;
with ADO.Objects;

with Security.Policies;
with Security.Contexts;
with Security.Policies.Roles;
package AWA.Permissions.Services is

   --  Register the security EL functions in the EL mapper.
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   type Permission_Manager is new Security.Policies.Policy_Manager with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access;

   --  Get the application instance.
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access;

   --  Set the application instance.
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access);

   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind in the Workspace.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type);

   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type);

   --  Get the role names that grant the given permission.
   function Get_Role_Names (Manager : in Permission_Manager;
                            Permission : in Security.Permissions.Permission_Index)
                            return Security.Policies.Roles.Role_Name_Array;

   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Create a permission manager for the given application.
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Policies.Policy_Manager_Access;

   --  Check if the permission with the name <tt>Name</tt> is granted for the current user.
   --  If the <tt>Entity</tt> is defined, an <tt>Entity_Permission</tt> is created and verified.
   --  Returns True if the user is granted the given permission.
   function Has_Permission (Name   : in Util.Beans.Objects.Object;
                            Entity : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

   --  Delete all the permissions for a user and on the given workspace.
   procedure Delete_Permissions (Session   : in out ADO.Sessions.Master_Session;
                                 User      : in ADO.Identifier;
                                 Workspace : in ADO.Identifier);

private

   type Permission_Manager is new Security.Policies.Policy_Manager with record
      App   : AWA.Applications.Application_Access;
      Roles : Security.Policies.Roles.Role_Policy_Access;
   end record;

end AWA.Permissions.Services;

-----------------------------------------------------------------------
--  awa-permissions-services -- Permissions controller
--  Copyright (C) 2011, 2012, 2013, 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 AWA.Applications;

with Util.Beans.Objects;

with EL.Functions;

with ADO;
with ADO.Sessions;
with ADO.Objects;

with Security.Policies;
with Security.Contexts;
with Security.Policies.Roles;
package AWA.Permissions.Services is

   --  Register the security EL functions in the EL mapper.
   procedure Set_Functions (Mapper : in out EL.Functions.Function_Mapper'Class);

   type Permission_Manager is new Security.Policies.Policy_Manager with private;
   type Permission_Manager_Access is access all Permission_Manager'Class;

   --  Get the permission manager associated with the security context.
   --  Returns null if there is none.
   function Get_Permission_Manager (Context : in Security.Contexts.Security_Context'Class)
                                    return Permission_Manager_Access;

   --  Get the application instance.
   function Get_Application (Manager : in Permission_Manager)
                             return AWA.Applications.Application_Access;

   --  Set the application instance.
   procedure Set_Application (Manager : in out Permission_Manager;
                              App : in AWA.Applications.Application_Access);

   --  Initialize the permissions.
   procedure Start (Manager : in out Permission_Manager);

   --  Add a permission for the current user to access the entity identified by
   --  Entity and Kind in the Workspace.
   procedure Add_Permission (Manager    : in Permission_Manager;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type);

   --  Check that the current user has the specified permission.
   --  Raise NO_PERMISSION exception if the user does not have the permission.
   procedure Check_Permission (Manager    : in Permission_Manager;
                               Entity     : in ADO.Identifier;
                               Kind       : in ADO.Entity_Type;
                               Permission : in Permission_Type);

   --  Get the role names that grant the given permission.
   function Get_Role_Names (Manager : in Permission_Manager;
                            Permission : in Security.Permissions.Permission_Index)
                            return Security.Policies.Roles.Role_Name_Array;

   --  Add a permission for the user User to access the entity identified by
   --  Entity which is of type Kind.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Identifier;
                             Kind       : in ADO.Entity_Type;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Add a permission for the user User to access the entity identified by
   --  Entity.
   procedure Add_Permission (Session    : in out ADO.Sessions.Master_Session;
                             User       : in ADO.Identifier;
                             Entity     : in ADO.Objects.Object_Ref'Class;
                             Workspace  : in ADO.Identifier;
                             Permission : in Permission_Type := READ);

   --  Create a permission manager for the given application.
   function Create_Permission_Manager (App : in AWA.Applications.Application_Access)
                                       return Security.Policies.Policy_Manager_Access;

   --  Check if the permission with the name <tt>Name</tt> is granted for the current user.
   --  If the <tt>Entity</tt> is defined, an <tt>Entity_Permission</tt> is created and verified.
   --  Returns True if the user is granted the given permission.
   function Has_Permission (Name   : in Util.Beans.Objects.Object;
                            Entity : in Util.Beans.Objects.Object)
                            return Util.Beans.Objects.Object;

   --  Delete all the permissions for a user and on the given workspace.
   procedure Delete_Permissions (Session   : in out ADO.Sessions.Master_Session;
                                 User      : in ADO.Identifier;
                                 Workspace : in ADO.Identifier);

private

   type Permission_Manager is new Security.Policies.Policy_Manager with record
      App   : AWA.Applications.Application_Access;
      Roles : Security.Policies.Roles.Role_Policy_Access;
   end record;

end AWA.Permissions.Services;

Declare the Start procedure to initialize the permission


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

   --  use Util.Log;
   use type Util.Log.Loggers.Logger_Access;

   --  The logger'
   Log : aliased constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Serialize.IO",
                                                                              Util.Log.WARN_LEVEL);

   --  ------------------------------
   --  Read the file and parse it using the JSON parser.
   --  ------------------------------
   procedure Parse (Handler : in out Parser;
                    File    : in String) is
      Stream     : aliased Util.Streams.Files.File_Stream;
      Buffer     : Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.Error_Logger.Info ("Reading file {0}", File);

      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String (File);
      Buffer.Initialize (Output => null,
                         Input  => Stream'Unchecked_Access,
                         Size   => 1024);
      Stream.Open (Mode => Ada.Streams.Stream_IO.In_File, Name => File);
      Context_Stack.Clear (Handler.Stack);
      Parser'Class (Handler).Parse (Buffer);

   exception
      when Util.Serialize.Mappers.Field_Fatal_Error =>
         null;

      when Ada.IO_Exceptions.Name_Error =>
         Parser'Class (Handler).Error ("File '" & File & "' does not exist.");

      when E : others =>
         Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
   end Parse;

   --  ------------------------------
   --  Parse the content string.
   --  ------------------------------
   procedure Parse_String (Handler : in out Parser;
                           Content : in String) is
      Stream : aliased Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String ("<inline>");
      Stream.Initialize (Content  => Content);
      Context_Stack.Clear (Handler.Stack);
      Parser'Class (Handler).Parse (Stream);

   exception
      when Util.Serialize.Mappers.Field_Fatal_Error =>
         null;

      when E : others =>
         Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
   end Parse_String;

   --  ------------------------------
   --  Returns true if the Parse operation detected at least one error.
   --  ------------------------------
   function Has_Error (Handler : in Parser) return Boolean is
   begin
      return Handler.Error_Flag;
   end Has_Error;

   --  ------------------------------
   --  Set the error logger to report messages while parsing and reading the input file.
   --  ------------------------------
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access) is
   begin
      Handler.Error_Logger := Logger;
   end Set_Logger;

   --  ------------------------------
   --  Push the current context when entering in an element.
   --  ------------------------------
   procedure Push (Handler : in out Parser) is
      use type Util.Serialize.Mappers.Mapper_Access;
   begin
      Context_Stack.Push (Handler.Stack);
   end Push;

   --  ------------------------------
   --  Pop the context and restore the previous context when leaving an element
   --  ------------------------------
   procedure Pop (Handler  : in out Parser) is
   begin
      Context_Stack.Pop (Handler.Stack);
   end Pop;

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access is
      pragma Unreferenced (Handler, Name);
   begin
      return null;
   end Find_Mapper;

   --  ------------------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  ------------------------------
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is

      use type Util.Serialize.Mappers.Mapper_Access;

      Current : constant Element_Context_Access := Context_Stack.Current (Handler.Stack);
      Next    : Element_Context_Access;
      Pos     : Positive;
   begin
      Log.Debug ("Start object {0}", Name);

      Context_Stack.Push (Handler.Stack);
      Next := Context_Stack.Current (Handler.Stack);
      if Current /= null then
         Pos := 1;

         --  Notify we are entering in the given node for each active mapping.
         for I in Current.Active_Nodes'Range loop
            declare
               Node  : constant Mappers.Mapper_Access := Current.Active_Nodes (I);
               Child : Mappers.Mapper_Access;
            begin
               exit when Node = null;
               Child := Node.Find_Mapper (Name => Name);
               if Child = null and then Node.Is_Wildcard then
                  Child := Node;
               end if;
               if Child /= null then
                  Log.Debug ("{0} is matching {1}", Name, Child.Get_Name);
                  Child.Start_Object (Handler, Name);
                  Next.Active_Nodes (Pos) := Child;
                  Pos := Pos + 1;
               end if;
            end;
         end loop;
         while Pos <= Next.Active_Nodes'Last loop
            Next.Active_Nodes (Pos) := null;
            Pos := Pos + 1;
         end loop;
      else
         Next.Active_Nodes (1) := Handler.Mapping_Tree.Find_Mapper (Name);
      end if;
   end Start_Object;

   --  ------------------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  ------------------------------
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is

      use type Util.Serialize.Mappers.Mapper_Access;
   begin
      Log.Debug ("Finish object {0}", Name);

      declare
         Current : constant Element_Context_Access := Context_Stack.Current (Handler.Stack);
      begin
         if Current /= null then
            --  Notify we are leaving the given node for each active mapping.
            for I in Current.Active_Nodes'Range loop
               declare
                  Node : constant Mappers.Mapper_Access := Current.Active_Nodes (I);
               begin
                  exit when Node = null;
                  Node.Finish_Object (Handler, Name);
               end;
            end loop;
         end if;
      end;
      Handler.Pop;
   end Finish_Object;

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String) is
      pragma Unreferenced (Name);
   begin
      Handler.Push;
   end Start_Array;

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String) is
      pragma Unreferenced (Name);
   begin
      Handler.Pop;
   end Finish_Array;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False) is
      use Util.Serialize.Mappers;

      Current : constant Element_Context_Access := Context_Stack.Current (Handler.Stack);
   begin
      Log.Debug ("Set member {0}", Name);

      if Current /= null then

         --  Look each active mapping node.
         for I in Current.Active_Nodes'Range loop
            declare
               Node : constant Mapper_Access := Current.Active_Nodes (I);
            begin
               exit when Node = null;
               Node.Set_Member (Name      => Name,
                                Value     => Value,
                                Attribute => Attribute,
                                Context   => Handler);

            exception
               when E : Util.Serialize.Mappers.Field_Error =>
                  Parser'Class (Handler).Error (Message => Ada.Exceptions.Exception_Message (E));

               when E : Util.Serialize.Mappers.Field_Fatal_Error =>
                  Parser'Class (Handler).Error (Message => Ada.Exceptions.Exception_Message (E));
                  raise;

                  --  For other exception, report an error with the field name and value.
               when E : others =>
                  Parser'Class (Handler).Error (Message => "Cannot set field '" & Name & "' to '"
                                                & Util.Beans.Objects.To_String (Value) & "': "
                                                & Ada.Exceptions.Exception_Message (E));
                  raise;
            end;
         end loop;
      end if;
   end Set_Member;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Handler.File);
   end Get_Location;

   --  ------------------------------
   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   --  ------------------------------
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      Handler.Error_Logger.Error ("{0}: {1}",
                                  Parser'Class (Handler).Get_Location,
                                  Message);
      Handler.Error_Flag := True;
   end Error;

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access) is
   begin
      Handler.Mapping_Tree.Add_Mapping (Path, Mapper);
   end Add_Mapping;

   --  ------------------------------
   --  Dump the mapping tree on the logger using the INFO log level.
   --  ------------------------------
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class) is
   begin
      Util.Serialize.Mappers.Dump (Handler.Mapping_Tree, Logger, "Mapping ");
   end Dump;

end Util.Serialize.IO;

-----------------------------------------------------------------------
--  util-serialize-io -- IO Drivers for serialization
--  Copyright (C) 2010, 2011, 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 Util.Streams.Files;
with Ada.Streams;
with Ada.Streams.Stream_IO;
with Ada.Exceptions;
with Ada.IO_Exceptions;
package body Util.Serialize.IO is

   --  use Util.Log;
   use type Util.Log.Loggers.Logger_Access;

   --  The logger'
   Log : aliased constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Util.Serialize.IO",
                                                                              Util.Log.WARN_LEVEL);
   procedure Write_Attribute (Stream : in out Output_Stream'Class;
                              Name   : in String;
                              Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Attribute (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Attribute;

   procedure Write_Entity (Stream : in out Output_Stream'Class;
                           Name   : in String;
                           Value  : in Ada.Strings.Unbounded.Unbounded_String) is
   begin
      Stream.Write_Entity (Name, Ada.Strings.Unbounded.To_String (Value));
   end Write_Entity;

   --  ------------------------------
   --  Read the file and parse it using the JSON parser.
   --  ------------------------------
   procedure Parse (Handler : in out Parser;
                    File    : in String) is
      Stream     : aliased Util.Streams.Files.File_Stream;
      Buffer     : Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.Error_Logger.Info ("Reading file {0}", File);

      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String (File);
      Buffer.Initialize (Output => null,
                         Input  => Stream'Unchecked_Access,
                         Size   => 1024);
      Stream.Open (Mode => Ada.Streams.Stream_IO.In_File, Name => File);
      Context_Stack.Clear (Handler.Stack);
      Parser'Class (Handler).Parse (Buffer);

   exception
      when Util.Serialize.Mappers.Field_Fatal_Error =>
         null;

      when Ada.IO_Exceptions.Name_Error =>
         Parser'Class (Handler).Error ("File '" & File & "' does not exist.");

      when E : others =>
         Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
   end Parse;

   --  ------------------------------
   --  Parse the content string.
   --  ------------------------------
   procedure Parse_String (Handler : in out Parser;
                           Content : in String) is
      Stream : aliased Util.Streams.Buffered.Buffered_Stream;
   begin
      if Handler.Error_Logger = null then
         Handler.Error_Logger := Log'Access;
      end if;
      Handler.File := Ada.Strings.Unbounded.To_Unbounded_String ("<inline>");
      Stream.Initialize (Content  => Content);
      Context_Stack.Clear (Handler.Stack);
      Parser'Class (Handler).Parse (Stream);

   exception
      when Util.Serialize.Mappers.Field_Fatal_Error =>
         null;

      when E : others =>
         Parser'Class (Handler).Error ("Exception " & Ada.Exceptions.Exception_Name (E));
   end Parse_String;

   --  ------------------------------
   --  Returns true if the Parse operation detected at least one error.
   --  ------------------------------
   function Has_Error (Handler : in Parser) return Boolean is
   begin
      return Handler.Error_Flag;
   end Has_Error;

   --  ------------------------------
   --  Set the error logger to report messages while parsing and reading the input file.
   --  ------------------------------
   procedure Set_Logger (Handler : in out Parser;
                         Logger  : in Util.Log.Loggers.Logger_Access) is
   begin
      Handler.Error_Logger := Logger;
   end Set_Logger;

   --  ------------------------------
   --  Push the current context when entering in an element.
   --  ------------------------------
   procedure Push (Handler : in out Parser) is
      use type Util.Serialize.Mappers.Mapper_Access;
   begin
      Context_Stack.Push (Handler.Stack);
   end Push;

   --  ------------------------------
   --  Pop the context and restore the previous context when leaving an element
   --  ------------------------------
   procedure Pop (Handler  : in out Parser) is
   begin
      Context_Stack.Pop (Handler.Stack);
   end Pop;

   function Find_Mapper (Handler : in Parser;
                         Name    : in String) return Util.Serialize.Mappers.Mapper_Access is
      pragma Unreferenced (Handler, Name);
   begin
      return null;
   end Find_Mapper;

   --  ------------------------------
   --  Start a new object associated with the given name.  This is called when
   --  the '{' is reached.  The reader must be updated so that the next
   --  Set_Member procedure will associate the name/value pair on the
   --  new object.
   --  ------------------------------
   procedure Start_Object (Handler : in out Parser;
                           Name    : in String) is

      use type Util.Serialize.Mappers.Mapper_Access;

      Current : constant Element_Context_Access := Context_Stack.Current (Handler.Stack);
      Next    : Element_Context_Access;
      Pos     : Positive;
   begin
      Log.Debug ("Start object {0}", Name);

      Context_Stack.Push (Handler.Stack);
      Next := Context_Stack.Current (Handler.Stack);
      if Current /= null then
         Pos := 1;

         --  Notify we are entering in the given node for each active mapping.
         for I in Current.Active_Nodes'Range loop
            declare
               Node  : constant Mappers.Mapper_Access := Current.Active_Nodes (I);
               Child : Mappers.Mapper_Access;
            begin
               exit when Node = null;
               Child := Node.Find_Mapper (Name => Name);
               if Child = null and then Node.Is_Wildcard then
                  Child := Node;
               end if;
               if Child /= null then
                  Log.Debug ("{0} is matching {1}", Name, Child.Get_Name);
                  Child.Start_Object (Handler, Name);
                  Next.Active_Nodes (Pos) := Child;
                  Pos := Pos + 1;
               end if;
            end;
         end loop;
         while Pos <= Next.Active_Nodes'Last loop
            Next.Active_Nodes (Pos) := null;
            Pos := Pos + 1;
         end loop;
      else
         Next.Active_Nodes (1) := Handler.Mapping_Tree.Find_Mapper (Name);
      end if;
   end Start_Object;

   --  ------------------------------
   --  Finish an object associated with the given name.  The reader must be
   --  updated to be associated with the previous object.
   --  ------------------------------
   procedure Finish_Object (Handler : in out Parser;
                            Name    : in String) is

      use type Util.Serialize.Mappers.Mapper_Access;
   begin
      Log.Debug ("Finish object {0}", Name);

      declare
         Current : constant Element_Context_Access := Context_Stack.Current (Handler.Stack);
      begin
         if Current /= null then
            --  Notify we are leaving the given node for each active mapping.
            for I in Current.Active_Nodes'Range loop
               declare
                  Node : constant Mappers.Mapper_Access := Current.Active_Nodes (I);
               begin
                  exit when Node = null;
                  Node.Finish_Object (Handler, Name);
               end;
            end loop;
         end if;
      end;
      Handler.Pop;
   end Finish_Object;

   procedure Start_Array (Handler : in out Parser;
                          Name    : in String) is
      pragma Unreferenced (Name);
   begin
      Handler.Push;
   end Start_Array;

   procedure Finish_Array (Handler : in out Parser;
                           Name    : in String) is
      pragma Unreferenced (Name);
   begin
      Handler.Pop;
   end Finish_Array;

   --  -----------------------
   --  Set the name/value pair on the current object.  For each active mapping,
   --  find whether a rule matches our name and execute it.
   --  -----------------------
   procedure Set_Member (Handler   : in out Parser;
                         Name      : in String;
                         Value     : in Util.Beans.Objects.Object;
                         Attribute : in Boolean := False) is
      use Util.Serialize.Mappers;

      Current : constant Element_Context_Access := Context_Stack.Current (Handler.Stack);
   begin
      Log.Debug ("Set member {0}", Name);

      if Current /= null then

         --  Look each active mapping node.
         for I in Current.Active_Nodes'Range loop
            declare
               Node : constant Mapper_Access := Current.Active_Nodes (I);
            begin
               exit when Node = null;
               Node.Set_Member (Name      => Name,
                                Value     => Value,
                                Attribute => Attribute,
                                Context   => Handler);

            exception
               when E : Util.Serialize.Mappers.Field_Error =>
                  Parser'Class (Handler).Error (Message => Ada.Exceptions.Exception_Message (E));

               when E : Util.Serialize.Mappers.Field_Fatal_Error =>
                  Parser'Class (Handler).Error (Message => Ada.Exceptions.Exception_Message (E));
                  raise;

                  --  For other exception, report an error with the field name and value.
               when E : others =>
                  Parser'Class (Handler).Error (Message => "Cannot set field '" & Name & "' to '"
                                                & Util.Beans.Objects.To_String (Value) & "': "
                                                & Ada.Exceptions.Exception_Message (E));
                  raise;
            end;
         end loop;
      end if;
   end Set_Member;

   --  ------------------------------
   --  Get the current location (file and line) to report an error message.
   --  ------------------------------
   function Get_Location (Handler : in Parser) return String is
   begin
      return Ada.Strings.Unbounded.To_String (Handler.File);
   end Get_Location;

   --  ------------------------------
   --  Report an error while parsing the input stream.  The error message will be reported
   --  on the logger associated with the parser.  The parser will be set as in error so that
   --  the Has_Error function will return True after parsing the whole file.
   --  ------------------------------
   procedure Error (Handler : in out Parser;
                    Message : in String) is
   begin
      Handler.Error_Logger.Error ("{0}: {1}",
                                  Parser'Class (Handler).Get_Location,
                                  Message);
      Handler.Error_Flag := True;
   end Error;

   procedure Add_Mapping (Handler : in out Parser;
                          Path    : in String;
                          Mapper  : in Util.Serialize.Mappers.Mapper_Access) is
   begin
      Handler.Mapping_Tree.Add_Mapping (Path, Mapper);
   end Add_Mapping;

   --  ------------------------------
   --  Dump the mapping tree on the logger using the INFO log level.
   --  ------------------------------
   procedure Dump (Handler : in Parser'Class;
                   Logger  : in Util.Log.Loggers.Logger'Class) is
   begin
      Util.Serialize.Mappers.Dump (Handler.Mapping_Tree, Logger, "Mapping ");
   end Dump;

end Util.Serialize.IO;

Implement the Write_Attribute and Write_Entity procedures based on Unbounded_String


-----------------------------------------------------------------------
--  wiki-writers-builders -- Wiki writer to a string builder
--  Copyright (C) 2011, 2012, 2013, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Characters.Conversions;
package body Wiki.Writers.Builders is

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Content);
   end Write;

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Unbounded_Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, To_Wide_Wide_String (Content));
   end Write;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Writer_Builder_Type;
                      Process : not null access procedure (Chunk : in Wide_Wide_String)) is
   begin
      Wide_Wide_Builders.Iterate (Source.Content, Process);
   end Iterate;

   --  ------------------------------
   --  Convert what was collected in the writer builder to a string and return it.
   --  ------------------------------
   function To_String (Source : in Writer_Builder_Type) return String is
      Pos    : Natural := 0;
      Result : String (1 .. Wide_Wide_Builders.Length (Source.Content));

      procedure Convert (Chunk : in Wide_Wide_String) is
      begin
         for I in Chunk'Range loop
            Pos := Pos + 1;
            Result (Pos) := Ada.Characters.Conversions.To_Character (Chunk (I));
         end loop;
      end Convert;

   begin
      Wide_Wide_Builders.Iterate (Source.Content, Convert'Access);
      return Result;
   end To_String;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write (Writer : in out Writer_Builder_Type;
                    Char   : in Wide_Wide_Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Char);
   end Write;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write_Char (Writer : in out Writer_Builder_Type;
                         Char   : in Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content,
                                 Ada.Characters.Conversions.To_Wide_Wide_Character (Char));
   end Write_Char;

   --  ------------------------------
   --  Write the string to the string builder.
   --  ------------------------------
   procedure Write_String (Writer : in out Writer_Builder_Type;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Writer.Write_Char (Content (I));
      end loop;
   end Write_String;

   type Unicode_Char is mod 2**31;

   --  ------------------------------
   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   --  ------------------------------
   procedure Write_Escape (Stream : in out Html_Writer_Type'Class;
                           Char   : in Wide_Wide_Character) is
      Code : constant Unicode_Char := Wide_Wide_Character'Pos (Char);
   begin
      --  If "?" or over, no escaping is needed (this covers
      --  most of the Latin alphabet)
      if Code > 16#3F# or Code <= 16#20# then
         Stream.Write (Char);
      elsif Char = '<' then
         Stream.Write ("<");
      elsif Char = '>' then
         Stream.Write (">");
      elsif Char = '&' then
         Stream.Write ("&");
      else
         Stream.Write (Char);
      end if;
   end Write_Escape;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_writer_Type'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write_Char ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   procedure Write_Wide_Element (Writer  : in out Html_writer_Type;
                                 Name    : in String;
                                 Content : in Unbounded_Wide_Wide_String) is

   begin
      Writer.Start_Element (Name);
      Writer.Write_Wide_Text (Content);
      Writer.End_Element (Name);
   end Write_Wide_Element;

   procedure Write_Wide_Attribute (Writer  : in out Html_writer_Type;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      if Writer.Close_Start then
         Writer.Write_Char (' ');
         Writer.Write_String (Name);
         Writer.Write_Char ('=');
         Writer.Write_Char ('"');
         for I in 1 .. Count loop
            declare
               C : constant Wide_Wide_Character := Element (Content, I);
            begin
               if C = '"' then
                  Writer.Write_String (""");
               else
                  Writer.Write_Escape (C);
               end if;
            end;
         end loop;
         Writer.Write_Char ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Start_Element (Writer : in out Html_Writer_Type;
                            Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_Char ('<');
      Writer.Write_String (Name);
      Writer.Close_Start := True;
   end Start_Element;

   procedure End_Element (Writer : in out Html_Writer_Type;
                          Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_String ("</");
      Writer.Write_String (Name);
      Writer.Write_Char ('>');
   end End_Element;

   procedure Write_Wide_Text (Writer  : in out Html_Writer_Type;
                              Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      Close_Current (Writer);
      if Count > 0 then
         for I in 1 .. Count loop
            Html_Writer_Type'Class (Writer).Write (Element (Content, I));
         end loop;
      end if;
   end Write_Wide_Text;

end Wiki.Writers.Builders;

-----------------------------------------------------------------------
--  wiki-writers-builders -- Wiki writer to a string builder
--  Copyright (C) 2011, 2012, 2013, 2015 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Characters.Conversions;
package body Wiki.Writers.Builders is

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Content);
   end Write;

   --  ------------------------------
   --  Write the content to the string builder.
   --  ------------------------------
   overriding
   procedure Write (Writer  : in out Writer_Builder_Type;
                    Content : in Unbounded_Wide_Wide_String) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, To_Wide_Wide_String (Content));
   end Write;

   --  ------------------------------
   --  Iterate over the buffer content calling the <tt>Process</tt> procedure with each
   --  chunk.
   --  ------------------------------
   procedure Iterate (Source  : in Writer_Builder_Type;
                      Process : not null access procedure (Chunk : in Wide_Wide_String)) is
   begin
      Wide_Wide_Builders.Iterate (Source.Content, Process);
   end Iterate;

   --  ------------------------------
   --  Convert what was collected in the writer builder to a string and return it.
   --  ------------------------------
   function To_String (Source : in Writer_Builder_Type) return String is
      Pos    : Natural := 0;
      Result : String (1 .. Wide_Wide_Builders.Length (Source.Content));

      procedure Convert (Chunk : in Wide_Wide_String) is
      begin
         for I in Chunk'Range loop
            Pos := Pos + 1;
            Result (Pos) := Ada.Characters.Conversions.To_Character (Chunk (I));
         end loop;
      end Convert;

   begin
      Wide_Wide_Builders.Iterate (Source.Content, Convert'Access);
      return Result;
   end To_String;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write (Writer : in out Writer_Builder_Type;
                    Char   : in Wide_Wide_Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content, Char);
   end Write;

   --  ------------------------------
   --  Write a single character to the string builder.
   --  ------------------------------
   procedure Write_Char (Writer : in out Writer_Builder_Type;
                         Char   : in Character) is
   begin
      Wide_Wide_Builders.Append (Writer.Content,
                                 Ada.Characters.Conversions.To_Wide_Wide_Character (Char));
   end Write_Char;

   --  ------------------------------
   --  Write the string to the string builder.
   --  ------------------------------
   procedure Write_String (Writer : in out Writer_Builder_Type;
                           Content : in String) is
   begin
      for I in Content'Range loop
         Writer.Write_Char (Content (I));
      end loop;
   end Write_String;

   type Unicode_Char is mod 2**31;

   --  ------------------------------
   --  Internal method to write a character on the response stream
   --  and escape that character as necessary.  Unlike 'Write_Char',
   --  this operation does not closes the current XML entity.
   --  ------------------------------
   procedure Write_Escape (Stream : in out Html_Writer_Type'Class;
                           Char   : in Wide_Wide_Character) is
      Code : constant Unicode_Char := Wide_Wide_Character'Pos (Char);
   begin
      --  If "?" or over, no escaping is needed (this covers
      --  most of the Latin alphabet)
      if Code > 16#3F# or Code <= 16#20# then
         Stream.Write (Char);
      elsif Char = '<' then
         Stream.Write ("<");
      elsif Char = '>' then
         Stream.Write (">");
      elsif Char = '&' then
         Stream.Write ("&");
      else
         Stream.Write (Char);
      end if;
   end Write_Escape;

   --  ------------------------------
   --  Close the current XML entity if an entity was started
   --  ------------------------------
   procedure Close_Current (Stream : in out Html_writer_Type'Class) is
   begin
      if Stream.Close_Start then
         Stream.Write_Char ('>');
         Stream.Close_Start := False;
      end if;
   end Close_Current;

   procedure Write_Wide_Element (Writer  : in out Html_writer_Type;
                                 Name    : in String;
                                 Content : in Unbounded_Wide_Wide_String) is

   begin
      Writer.Start_Element (Name);
      Writer.Write_Wide_Text (Content);
      Writer.End_Element (Name);
   end Write_Wide_Element;

   procedure Write_Wide_Attribute (Writer  : in out Html_writer_Type;
                                   Name    : in String;
                                   Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      if Writer.Close_Start then
         Writer.Write_Char (' ');
         Writer.Write_String (Name);
         Writer.Write_Char ('=');
         Writer.Write_Char ('"');
         for I in 1 .. Count loop
            declare
               C : constant Wide_Wide_Character := Element (Content, I);
            begin
               if C = '"' then
                  Writer.Write_String (""");
               else
                  Writer.Write_Escape (C);
               end if;
            end;
         end loop;
         Writer.Write_Char ('"');
      end if;
   end Write_Wide_Attribute;

   procedure Start_Element (Writer : in out Html_Writer_Type;
                            Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_Char ('<');
      Writer.Write_String (Name);
      Writer.Close_Start := True;
   end Start_Element;

   procedure End_Element (Writer : in out Html_Writer_Type;
                          Name   : in String) is
   begin
      Close_Current (Writer);
      Writer.Write_String ("</");
      Writer.Write_String (Name);
      Writer.Write_Char ('>');
   end End_Element;

   procedure Write_Wide_Text (Writer  : in out Html_Writer_Type;
                              Content : in Unbounded_Wide_Wide_String) is
      Count : constant Natural := Length (Content);
   begin
      Close_Current (Writer);
      if Count > 0 then
         for I in 1 .. Count loop
            Html_Writer_Type'Class (Writer).Write_Escape (Element (Content, I));
         end loop;
      end if;
   end Write_Wide_Text;

end Wiki.Writers.Builders;

Use Write_Escape to escape the characters