------------------------------------------------------------------------------
--                                                                          --
--                  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.   --
--                                                                          --
------------------------------------------------------------------------------

--  Based on ft6x06.h from MCD Application Team

with Ada.Real_Time; use Ada.Real_Time;
with Ada.Unchecked_Conversion;

with STM32.Board;   use STM32.Board;
with STM32.Device;  use STM32.Device;
with STM32.I2C;     use STM32.I2C;
with STM32.GPIO;    use STM32.GPIO;
with STM32.LCD;

with FT6x06;        use FT6x06;

package body STM32.Touch_Panel is

   --  I2C Slave address of touchscreen FocalTech FT5336
   TP_ADDR  : constant := 16#54#;

   procedure My_Delay (Ms : Integer);
   --  Wait the specified number of milliseconds

   function TP_Read (Reg : Byte; Status : out I2C_Status) return Byte
     with Inline;
   --  Reads a Touch Panel register value

   procedure TP_Write (Reg : Byte; Data :  Byte; Status : out I2C_Status)
     with Inline;
   --  Write a Touch Panel register value

   procedure TP_Init_Pins;
   --  Initializes the Touch Panel GPIO pins

   procedure TP_I2C_Config;
   --  Initializes the I2C bus

   function Check_Id return Boolean;
   --  Check the device Id: returns true on a FT5336 touch panel, False is
   --  none is found.

   procedure TP_Set_Use_Interrupts (Enabled : Boolean);
   --  Whether the touch panel uses interrupts of polling to process touch
   --  information

   function Get_Touch_State
     (Touch_Id : Byte;
      Status   : out I2C_Status) return TP_Touch_State;
   --  Retrieves the position and pressure information of the specified
   --  touch

   pragma Warnings (Off, "* is not referenced");

   pragma Warnings (On, "* is not referenced");

   --------------
   -- My_Delay --
   --------------

   procedure My_Delay (Ms : Integer) is
      Next_Start : Time := Clock;
      Period    : constant Time_Span := Milliseconds (Ms);
   begin
      Next_Start := Next_Start + Period;
      delay until Next_Start;
   end My_Delay;

   -------------
   -- TS_Read --
   -------------

   function TP_Read (Reg : Byte; Status : out I2C_Status) return Byte
   is
      Ret : I2C_Data (1 .. 1);
   begin
      STM32.I2C.Mem_Read
        (TP_I2C,
         TP_ADDR,
         Short (Reg),
         Memory_Size_8b,
         Ret,
         Status,
         1000);
      return Ret (1);
   end TP_Read;

   -------------
   -- TS_Read --
   -------------

   procedure TP_Write (Reg : Byte; Data :  Byte; Status : out I2C_Status)
   is
   begin
      STM32.I2C.Mem_Write
        (TP_I2C,
         TP_ADDR,
         Short (Reg),
         Memory_Size_8b,
         (1 => Data),
         Status,
         1000);
   end TP_Write;

   ---------------
   -- Init_Pins --
   ---------------

   procedure TP_Init_Pins
   is
      Pins : constant GPIO_Points := TP_Pins;
   begin
      Enable_Clock (Pins);

      Reset (TP_I2C);

      Configure_Alternate_Function (Pins, GPIO_AF_I2C);
      Configure_IO (Pins,
                    (Speed       => Speed_25MHz,
                     Mode        => Mode_AF,
                     Output_Type => Open_Drain,
                     Resistors   => Floating));
      Lock (Pins);

      Enable_Clock (TP_INT);

      Configure_IO (TP_INT,
                    (Speed       => Speed_50MHz,
                     Mode        => Mode_In,
                     Output_Type => Open_Drain,
                     Resistors   => Pull_Up));
      Lock (TP_INT);
   end TP_Init_Pins;

   -------------------
   -- TP_I2C_Config --
   -------------------

   procedure TP_I2C_Config
   is
      I2C_Conf : I2C_Configuration;
   begin
      --  Wait at least 200ms after power up before accessing the TP registers
      My_Delay (200);

      if not I2C.Port_Enabled (TP_I2C) then
         Reset (TP_I2C);

         I2C_Conf.Own_Address := 16#00#;
         I2C_Conf.Addressing_Mode := Addressing_Mode_7bit;
         I2C_Conf.General_Call_Enabled := False;
         I2C_Conf.Clock_Stretching_Enabled := True;

         I2C_Conf.Clock_Speed := 100_000;

         Configure (TP_I2C, I2C_Conf);
      end if;
   end TP_I2C_Config;

   ---------------------------
   -- TP_Set_Use_Interrupts --
   ---------------------------

   procedure TP_Set_Use_Interrupts (Enabled : Boolean)
   is
      Reg_Value : Byte := 0;
      Status    : I2C_Status with Unreferenced;
   begin
      if Enabled then
         Reg_Value := FT6206_G_MODE_INTERRUPT_TRIGGER;
      else
         Reg_Value := FT6206_G_MODE_INTERRUPT_POLLING;
      end if;

      TP_Write (FT6206_GMODE_REG, Reg_Value, Status);
   end TP_Set_Use_Interrupts;

   -------------
   -- Read_Id --
   -------------

   function Check_Id return Boolean
   is
      Id     : Byte;
      Status : I2C_Status;
   begin
      for J in 1 .. 3 loop
         Id := TP_Read (FT6206_CHIP_ID_REG, Status);

         if Id = FT6206_ID_VALUE then
            return True;
         end if;

         if Status = Err_Error then
            return False;
         end if;
      end loop;

      return False;
   end Check_Id;

   ----------------
   -- Initialize --
   ----------------

   function Initialize return Boolean is
   begin
      TP_Init_Pins;
      TP_I2C_Config;

      TP_Set_Use_Interrupts (False);

      return Check_Id;
   end Initialize;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      Ret : Boolean with Unreferenced;
   begin
      Ret := Initialize;
   end Initialize;

   ------------------
   -- Detect_Touch --
   ------------------

   function Detect_Touch return Natural
   is
     Status   : I2C_Status;
     Nb_Touch : Byte := 0;
   begin
      Nb_Touch := TP_Read (FT6206_TD_STAT_REG, Status);

      if Status /= Ok then
         return 0;
      end if;

      Nb_Touch := Nb_Touch and FT6206_TD_STAT_MASK;

      if Nb_Touch > FT6206_Px_Regs'Last then
         --  Overflow: set to 0
         Nb_Touch := 0;
      end if;

      return Natural (Nb_Touch);
   end Detect_Touch;

   ---------------------
   -- Get_Touch_State --
   ---------------------

   function Get_Touch_State
     (Touch_Id : Byte;
      Status   : out I2C_Status) return TP_Touch_State
   is
      type Short_HL_Type is record
         High, Low : Byte;
      end record with Size => 16;
      for Short_HL_Type use record
         High at 1 range 0 .. 7;
         Low  at 0 range 0 .. 7;
      end record;

      function To_Short is
        new Ada.Unchecked_Conversion (Short_HL_Type, Short);

      RX   : Natural;
      RY   : Natural;
      Rtmp : Natural;
      Ret  : TP_Touch_State;
      Regs : FT6206_Pressure_Registers;
      Tmp  : Short_HL_Type;

   begin
      if Touch_Id > 10 then
         Status := Err_Error;
         return (others => 0);
      end if;

      --  X/Y are swaped from the screen coordinates

      Regs := FT6206_Px_Regs (Touch_Id);

      Tmp.Low := TP_Read (Regs.XL_Reg, Status);

      if Status /= Ok then
         return Ret;
      end if;

      Tmp.High := TP_Read (Regs.XH_Reg, Status) and FT6206_TOUCH_POS_MSB_MASK;

      if Status /= Ok then
         return Ret;
      end if;

      RY := Natural (To_Short (Tmp) - 1);

      Tmp.Low := TP_Read (Regs.YL_Reg, Status);

      if Status /= Ok then
         return Ret;
      end if;

      Tmp.High := TP_Read (Regs.YH_Reg, Status) and FT6206_TOUCH_POS_MSB_MASK;

      if Status /= Ok then
         return Ret;
      end if;

      RX := Natural (To_Short (Tmp) - 1);

      Ret.Weight := Natural (TP_Read (Regs.Weight_Reg, Status));

      if Status /= Ok then
         Ret.Weight := 0;
         return Ret;
      end if;

      if Ret.Weight = 0 then
         Ret.Weight := 50;
      end if;

      if LCD.SwapXY then
         RTmp := RX;
         RX   := RY;
         RY   := RTmp;
         RX   := STM32.LCD.Pixel_Width - RX - 1;
      end if;

      RX := Natural'Max (0, RX);
      RY := Natural'Max (0, RY);
      RX := Natural'Min (LCD.Pixel_Width - 1, RX);
      RY := Natural'Min (LCD.Pixel_Height - 1, RY);

      --  ??? On the STM32F426, Y is returned reverted
      RY := STM32.LCD.LCD_Natural_Height - RY - 1;

      Ret.X := RX;
      Ret.Y := RY;

      return Ret;
   end Get_Touch_State;

   ---------------
   -- Get_State --
   ---------------

   function Get_State return TP_State
   is
      Status  : I2C_Status;
      N_Touch : constant Natural := Detect_Touch;
      State   : TP_State (1 .. N_Touch);

   begin
      if N_Touch = 0 then
         return (1 .. 0 => <>);
      end if;

      for J in State'Range loop
         State (J) := Get_Touch_State (Byte (J), Status);
         if Status /= Ok then
            return (1 .. 0 => <>);
         end if;
      end loop;

      return State;
   end Get_State;

end STM32.Touch_Panel;

------------------------------------------------------------------------------
--                                                                          --
--                  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.   --
--                                                                          --
------------------------------------------------------------------------------

--  Based on ft6x06.h from MCD Application Team

with Ada.Real_Time; use Ada.Real_Time;
with Ada.Unchecked_Conversion;

with STM32.Board;   use STM32.Board;
with STM32.Device;  use STM32.Device;
with STM32.I2C;     use STM32.I2C;
with STM32.GPIO;    use STM32.GPIO;
with STM32.LCD;

with FT6x06;        use FT6x06;

package body STM32.Touch_Panel is

   --  I2C Slave address of touchscreen FocalTech FT5336
   TP_ADDR  : constant := 16#54#;

   procedure My_Delay (Ms : Integer);
   --  Wait the specified number of milliseconds

   function TP_Read (Reg : Byte; Status : out I2C_Status) return Byte
     with Inline;
   --  Reads a Touch Panel register value

   procedure TP_Write (Reg : Byte; Data :  Byte; Status : out I2C_Status)
     with Inline;
   --  Write a Touch Panel register value

   procedure TP_Init_Pins;
   --  Initializes the Touch Panel GPIO pins

   procedure TP_I2C_Config;
   --  Initializes the I2C bus

   function Check_Id return Boolean;
   --  Check the device Id: returns true on a FT5336 touch panel, False is
   --  none is found.

   procedure TP_Set_Use_Interrupts (Enabled : Boolean);
   --  Whether the touch panel uses interrupts of polling to process touch
   --  information

   function Get_Touch_State
     (Touch_Id : Byte;
      Status   : out I2C_Status) return TP_Touch_State;
   --  Retrieves the position and pressure information of the specified
   --  touch

   pragma Warnings (Off, "* is not referenced");

   pragma Warnings (On, "* is not referenced");

   --------------
   -- My_Delay --
   --------------

   procedure My_Delay (Ms : Integer) is
      Next_Start : Time := Clock;
      Period    : constant Time_Span := Milliseconds (Ms);
   begin
      Next_Start := Next_Start + Period;
      delay until Next_Start;
   end My_Delay;

   -------------
   -- TS_Read --
   -------------

   function TP_Read (Reg : Byte; Status : out I2C_Status) return Byte
   is
      Ret : I2C_Data (1 .. 1);
   begin
      STM32.I2C.Mem_Read
        (TP_I2C,
         TP_ADDR,
         Short (Reg),
         Memory_Size_8b,
         Ret,
         Status,
         1000);
      return Ret (1);
   end TP_Read;

   -------------
   -- TS_Read --
   -------------

   procedure TP_Write (Reg : Byte; Data :  Byte; Status : out I2C_Status)
   is
   begin
      STM32.I2C.Mem_Write
        (TP_I2C,
         TP_ADDR,
         Short (Reg),
         Memory_Size_8b,
         (1 => Data),
         Status,
         1000);
   end TP_Write;

   ---------------
   -- Init_Pins --
   ---------------

   procedure TP_Init_Pins
   is
      Pins : constant GPIO_Points := TP_Pins;
   begin
      Enable_Clock (Pins);

      Reset (TP_I2C);

      Configure_Alternate_Function (Pins, GPIO_AF_I2C);
      Configure_IO (Pins,
                    (Speed       => Speed_25MHz,
                     Mode        => Mode_AF,
                     Output_Type => Open_Drain,
                     Resistors   => Floating));
      Lock (Pins);

      Enable_Clock (TP_INT);

      Configure_IO (TP_INT,
                    (Speed       => Speed_50MHz,
                     Mode        => Mode_In,
                     Output_Type => Open_Drain,
                     Resistors   => Pull_Up));
      Lock (TP_INT);
   end TP_Init_Pins;

   -------------------
   -- TP_I2C_Config --
   -------------------

   procedure TP_I2C_Config
   is
      I2C_Conf : I2C_Configuration;
   begin
      --  Wait at least 200ms after power up before accessing the TP registers
      My_Delay (200);

      if not I2C.Port_Enabled (TP_I2C) then
         Reset (TP_I2C);

         I2C_Conf.Own_Address := 16#00#;
         I2C_Conf.Addressing_Mode := Addressing_Mode_7bit;
         I2C_Conf.General_Call_Enabled := False;
         I2C_Conf.Clock_Stretching_Enabled := True;

         I2C_Conf.Clock_Speed := 100_000;

         Configure (TP_I2C, I2C_Conf);
      end if;
   end TP_I2C_Config;

   ---------------------------
   -- TP_Set_Use_Interrupts --
   ---------------------------

   procedure TP_Set_Use_Interrupts (Enabled : Boolean)
   is
      Reg_Value : Byte := 0;
      Status    : I2C_Status with Unreferenced;
   begin
      if Enabled then
         Reg_Value := FT6206_G_MODE_INTERRUPT_TRIGGER;
      else
         Reg_Value := FT6206_G_MODE_INTERRUPT_POLLING;
      end if;

      TP_Write (FT6206_GMODE_REG, Reg_Value, Status);
   end TP_Set_Use_Interrupts;

   -------------
   -- Read_Id --
   -------------

   function Check_Id return Boolean
   is
      Id     : Byte;
      Status : I2C_Status;
   begin
      for J in 1 .. 3 loop
         Id := TP_Read (FT6206_CHIP_ID_REG, Status);

         if Id = FT6206_ID_VALUE then
            return True;
         end if;

         if Status = Err_Error then
            return False;
         end if;
      end loop;

      return False;
   end Check_Id;

   ----------------
   -- Initialize --
   ----------------

   function Initialize return Boolean is
   begin
      TP_Init_Pins;
      TP_I2C_Config;

      TP_Set_Use_Interrupts (False);

      return Check_Id;
   end Initialize;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      Ret : Boolean with Unreferenced;
   begin
      Ret := Initialize;
   end Initialize;

   ------------------
   -- Detect_Touch --
   ------------------

   function Detect_Touch return Natural
   is
     Status   : I2C_Status;
     Nb_Touch : Byte := 0;
   begin
      Nb_Touch := TP_Read (FT6206_TD_STAT_REG, Status);

      if Status /= Ok then
         return 0;
      end if;

      Nb_Touch := Nb_Touch and FT6206_TD_STAT_MASK;

      if Nb_Touch > FT6206_Px_Regs'Last then
         --  Overflow: set to 0
         Nb_Touch := 0;
      end if;

      return Natural (Nb_Touch);
   end Detect_Touch;

   ---------------------
   -- Get_Touch_State --
   ---------------------

   function Get_Touch_State
     (Touch_Id : Byte;
      Status   : out I2C_Status) return TP_Touch_State
   is
      type Short_HL_Type is record
         High, Low : Byte;
      end record with Size => 16;
      for Short_HL_Type use record
         High at 1 range 0 .. 7;
         Low  at 0 range 0 .. 7;
      end record;

      function To_Short is
        new Ada.Unchecked_Conversion (Short_HL_Type, Short);

      RX   : Natural;
      RY   : Natural;
      Rtmp : Natural;
      Ret  : TP_Touch_State;
      Regs : FT6206_Pressure_Registers;
      Tmp  : Short_HL_Type;

   begin
      if Touch_Id > 10 then
         Status := Err_Error;
         return (others => 0);
      end if;

      --  X/Y are swaped from the screen coordinates

      Regs := FT6206_Px_Regs (Touch_Id);

      Tmp.Low := TP_Read (Regs.XL_Reg, Status);

      if Status /= Ok then
         return Ret;
      end if;

      Tmp.High := TP_Read (Regs.XH_Reg, Status) and FT6206_TOUCH_POS_MSB_MASK;

      if Status /= Ok then
         return Ret;
      end if;

      RY := Natural (To_Short (Tmp) - 1);

      Tmp.Low := TP_Read (Regs.YL_Reg, Status);

      if Status /= Ok then
         return Ret;
      end if;

      Tmp.High := TP_Read (Regs.YH_Reg, Status) and FT6206_TOUCH_POS_MSB_MASK;

      if Status /= Ok then
         return Ret;
      end if;

      RX := Natural (To_Short (Tmp) - 1);

      Ret.Weight := Natural (TP_Read (Regs.Weight_Reg, Status));

      if Status /= Ok then
         Ret.Weight := 0;
         return Ret;
      end if;

      if Ret.Weight = 0 then
         Ret.Weight := 50;
      end if;

      if LCD.SwapXY then
         RTmp := RX;
         RX   := RY;
         RY   := RTmp;
         RX   := STM32.LCD.Pixel_Width - RX - 1;
      end if;

      RX := Natural'Max (0, RX);
      RY := Natural'Max (0, RY);
      RX := Natural'Min (LCD.Pixel_Width - 1, RX);
      RY := Natural'Min (LCD.Pixel_Height - 1, RY);

      --  ??? On the STM32F426, Y is returned reverted
      RY := STM32.LCD.LCD_Natural_Height - RY - 1;
      RY := RY * 11 / 10;

      Ret.X := RX;
      Ret.Y := RY;

      return Ret;
   end Get_Touch_State;

   ---------------
   -- Get_State --
   ---------------

   function Get_State return TP_State
   is
      Status  : I2C_Status;
      N_Touch : constant Natural := Detect_Touch;
      State   : TP_State (1 .. N_Touch);

   begin
      if N_Touch = 0 then
         return (1 .. 0 => <>);
      end if;

      for J in State'Range loop
         State (J) := Get_Touch_State (Byte (J), Status);
         if Status /= Ok then
            return (1 .. 0 => <>);
         end if;
      end loop;

      return State;
   end Get_State;

end STM32.Touch_Panel;

Fix slight deviation between the touch panel coordinates and LCD coordinates.

On the STM32F469-disco board


-----------------------------------------------------------------------
--  awa-wikis-modules -- Module wikis
--  Copyright (C) 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 AWA.Modules.Get;
with Util.Log.Loggers;
package body Awa.Wikis.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Wikis.Module");

   --  ------------------------------
   --  Initialize the wikis module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Wiki_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the wikis module");

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the wikis module.
   --  ------------------------------
   function Get_Wiki_Module return Wiki_Module_Access is
      function Get is new AWA.Modules.Get (Wiki_Module, Wiki_Module_Access, NAME);
   begin
      return Get;
   end Get_Wiki_Module;

end Awa.Wikis.Modules;

-----------------------------------------------------------------------
--  awa-wikis-modules -- Module wikis
--  Copyright (C) 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 AWA.Services.Contexts;
with AWA.Workspaces.Models;
with AWA.Workspaces.Modules;
with AWA.Modules.Get;
with AWA.Permissions;
with AWA.Permissions.Services;

with ADO.Sessions;

with Util.Log.Loggers;
package body AWA.Wikis.Modules is

   Log : constant Util.Log.Loggers.Logger := Util.Log.Loggers.Create ("Awa.Wikis.Module");

   --  ------------------------------
   --  Initialize the wikis module.
   --  ------------------------------
   overriding
   procedure Initialize (Plugin : in out Wiki_Module;
                         App    : in AWA.Modules.Application_Access;
                         Props  : in ASF.Applications.Config) is
   begin
      Log.Info ("Initializing the wikis module");

      AWA.Modules.Module (Plugin).Initialize (App, Props);

      --  Add here the creation of manager instances.
   end Initialize;

   --  ------------------------------
   --  Get the wikis module.
   --  ------------------------------
   function Get_Wiki_Module return Wiki_Module_Access is
      function Get is new AWA.Modules.Get (Wiki_Module, Wiki_Module_Access, NAME);
   begin
      return Get;
   end Get_Wiki_Module;

   --  ------------------------------
   --  Create the wiki space.
   --  ------------------------------
   procedure Create_Wiki_Space (Module : in Wiki_Module;
                                Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class) is
      pragma Unreferenced (Module);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      User  : constant ADO.Identifier := Ctx.Get_User_Identifier;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
      WS    : AWA.Workspaces.Models.Workspace_Ref;
   begin
      Log.Info ("Creating new wiki space {0}", String '(Wiki.Get_Name));

      Ctx.Start;
      AWA.Workspaces.Modules.Get_Workspace (DB, Ctx, WS);

      --  Check that the user has the create permission on the given workspace.
      AWA.Permissions.Check (Permission => ACL_Create_Wiki_Space.Permission,
                             Entity     => WS);
      Wiki.Set_Workspace (WS);
      Wiki.Save (DB);

      --  Add the permission for the user to use the new wiki space.
      AWA.Permissions.Services.Add_Permission (Session => DB,
                                               User    => User,
                                               Entity  => Wiki);
      Ctx.Commit;

      Log.Info ("Wiki {0} created for user {1}",
                ADO.Identifier'Image (Wiki.Get_Id), ADO.Identifier'Image (User));
   end Create_Wiki_Space;

   --  ------------------------------
   --  Save the wiki space.
   --  ------------------------------
   procedure Save_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class) is
      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Master_Session := AWA.Services.Contexts.Get_Master_Session (Ctx);
   begin
      Log.Info ("Updating wiki space {0}", String '(Wiki.Get_Name));

      Ctx.Start;

      --  Check that the user has the update permission on the given wiki space.
      AWA.Permissions.Check (Permission => ACL_Update_Wiki_Space.Permission,
                             Entity     => Wiki);
      Wiki.Save (DB);
      Ctx.Commit;
   end Save_Wiki_Space;

   --  ------------------------------
   --  Load the wiki space.
   --  ------------------------------
   procedure Load_Wiki_Space (Module : in Wiki_Module;
                              Wiki   : in out AWA.Wikis.Models.Wiki_Space_Ref'Class;
                              Id     : in ADO.Identifier) is
      pragma Unreferenced (Module);

      Ctx   : constant Services.Contexts.Service_Context_Access := AWA.Services.Contexts.Current;
      DB    : ADO.Sessions.Session := AWA.Services.Contexts.Get_Session (Ctx);
      Found : Boolean;
   begin
      Wiki.Load (DB, Id, Found);
   end Load_Wiki_Space;

end AWA.Wikis.Modules;

Implement the Create_Wiki_Space procedure


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

generic
   type Property_Type is (<>);
   --  with function To_String (Val : Property_Type) return String is <>;
   --  with function From_String (Val : String) return Property_Type is <>;
package Util.Properties.Discrete is

   --  Get the property value
   function Get (Self : in Manager'Class;
                 Name : in String) return Property_Type;

   --  Get the property value.
   --  Return the default if the property does not exist.
   function Get (Self    : in Manager'Class;
                 Name    : in String;
                 Default : in Property_Type) return Property_Type;

   --  Set the property value
   procedure Set (Self  : in out Manager'Class;
                  Name  : in String;
                  Value : in Property_Type);

end Util.Properties.Discrete;

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

generic
   type Property_Type is (<>);
   --  with function To_String (Val : Property_Type) return String is <>;
   --  with function From_String (Val : String) return Property_Type is <>;
package Util.Properties.Discrete is

   --  Get the property value
   function Get (Self : in Manager'Class;
                 Name : in String) return Property_Type;

   --  Get the property value.
   --  Return the default if the property does not exist.
   function Get (Self    : in Manager'Class;
                 Name    : in String;
                 Default : in Property_Type) return Property_Type;

   --  Set the property value
   procedure Set (Self  : in out Manager'Class;
                  Name  : in String;
                  Value : in Property_Type);

end Util.Properties.Discrete;

Fix header style

Fix header style


-----------------------------------------------------------------------
--  asf-routes -- Request routing
--  Copyright (C) 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.Finalization;

with Util.Beans.Basic;
with EL.Expressions;
with EL.Contexts;

package ASF.Routes is

   type Route_Type is limited interface;
   type Route_Type_Access is access all Route_Type'Class;

   --  The <tt>Route_Context_Type</tt> defines the context information after a path
   --  has been routed.
   type Route_Context_Type is tagged limited private;

   --  Get path information after the routing.
   function Get_Path_Info (Context : in Route_Context_Type) return String;

   --  Return the route associated with the resolved route context.
   function Get_Route (Context : in Route_Context_Type) return Route_Type_Access;

   --  Inject the parameters that have been extracted from the path according
   --  to the selected route.
   procedure Inject_Parameters (Context   : in Route_Context_Type;
                                Into      : in out Util.Beans.Basic.Bean'Class;
                                ELContext : in EL.Contexts.ELContext'Class);

   --  The <tt>Router_Type</tt> registers the different routes with their rules and
   --  resolves a path into a route context information.
   type Router_Type is new Ada.Finalization.Limited_Controlled with private;
   type Router_Type_Access is access all Router_Type'Class;

   --  Add a route associated with the given path pattern.  The pattern is split into components.
   --  Some path components can be a fixed string (/home) and others can be variable.
   --  When a path component is variable, the value can be retrieved from the route context.
   procedure Add_Route (Router    : in out Router_Type;
                        Pattern   : in String;
                        To        : in Route_Type_Access;
                        ELContext : in EL.Contexts.ELContext'Class);

   --  Build the route context from the given path by looking at the different routes registered
   --  in the router with <tt>Add_Route</tt>.
   procedure Find_Route (Router  : in Router_Type;
                         Path    : in String;
                         Context : in out Route_Context_Type'Class);

   --  Walk the routes that have been added by <tt>Add_Route</tt> and call the <tt>Process</tt>
   --  procedure with each path pattern and route object.
   procedure Iterate (Router  : in Router_Type;
                      Process : not null access procedure (Pattern : in String;
                                                           Route   : in Route_Type_Access));

private

   type String_Access is access all String;

   type Route_Node_Type;
   type Route_Node_Access is access all Route_Node_Type'Class;

   type Route_Match_Type is (NO_MATCH, MAYBE_MATCH, WILDCARD_MATCH, YES_MATCH);

   type Route_Node_Type is abstract tagged limited record
      Next_Route : Route_Node_Access;
      Children   : Route_Node_Access;
      Route      : Route_Type_Access;
   end record;

   --  Inject the parameter that was extracted from the path.
   procedure Inject_Parameter (Node      : in Route_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class) is abstract;

   --  Check if the route node accepts the given path component.
   function Matches (Node    : in Route_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type is abstract;

   --  Return the component path pattern that this route node represents.
   --  Example: 'index.html', '#{user.id}', ':id'
   function Get_Pattern (Node : in Route_Node_Type) return String is abstract;

   --  Find recursively a match on the given route sub-tree.  The match must start at the position
   --  <tt>First</tt> in the path up to the last path position.  While the path components are
   --  checked, the route context is populated with variable components.  When the full path
   --  matches, <tt>YES_MATCH</tt> is returned in the context gets the route instance.
   procedure Find_Match (Node    : in Route_Node_Type;
                         Path    : in String;
                         First   : in Natural;
                         Match   : out Route_Match_Type;
                         Context : in out Route_Context_Type'Class);

   --  Walk the routes that have been added by <tt>Add_Route</tt> and call the <tt>Process</tt>
   --  procedure with each path pattern and route object.
   procedure Iterate (Node    : in Route_Node_Type;
                      Path    : in String;
                      Process : not null access procedure (Pattern : in String;
                                                           Route   : in Route_Type_Access));

   --  A fixed path component identification.
   type Path_Node_Type (Len : Natural) is new Route_Node_Type with record
      Name : aliased String (1 .. Len);
   end record;
   type Path_Node_Access is access all Path_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns YES_MATCH if the name corresponds exactly to the node's name.
   overriding
   function Matches (Node    : in Path_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, 'Name').
   overriding
   function Get_Pattern (Node : in Path_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in Path_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class) is null;

   --  A variable path component whose value is injected in an Ada bean using the EL expression.
   --  The route node is created each time an EL expression is found in the route pattern.
   --  Example: /home/#{user.id}/index.html
   --  In this example, the EL expression refers to <tt>user.id</tt>.
   type EL_Node_Type is new Route_Node_Type with record
      Value : EL.Expressions.Value_Expression;
   end record;
   type EL_Node_Access is access all EL_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in EL_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, the EL expr).
   overriding
   function Get_Pattern (Node : in EL_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in EL_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class);

   --  A variable path component which can be injected in an Ada bean.
   --  Example: /home/:id/view.html
   --  The path component represented by <tt>:id</tt> is injected in the Ada bean object
   --  passed to the <tt>Inject_Parameters</tt> procedure.
   type Param_Node_Type (Len : Natural) is new Route_Node_Type with record
      Name : String (1 .. Len);
   end record;
   type Param_Node_Access is access all Param_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in Param_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, Name).
   overriding
   function Get_Pattern (Node : in Param_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in Param_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class);

   type Extension_Node_Type (Len : Natural) is new Route_Node_Type with record
      Ext : String (1 .. Len);
   end record;
   type Extension_Node_Access is access all Extension_Node_Type'Class;

   --  Check if the route node accepts the given extension.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in Extension_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, *.Ext).
   overriding
   function Get_Pattern (Node : in Extension_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in Extension_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class) is null;

   --  Describes a variable path component whose value must be injected in an Ada bean.
   type Route_Param_Type is limited record
      Route : Route_Node_Access;
      First : Natural := 0;
      Last  : Natural := 0;
   end record;

   type Route_Param_Array is array (Positive range <>) of Route_Param_Type;

   MAX_ROUTE_PARAMS : constant Positive := 10;

   type Route_Context_Type is limited new Ada.Finalization.Limited_Controlled with record
      Route  : Route_Type_Access;
      Path   : String_Access;
      Params : Route_Param_Array (1 .. MAX_ROUTE_PARAMS);
      Count  : Natural := 0;
   end record;

   --  Release the storage held by the route context.
   overriding
   procedure Finalize (Context : in out Route_Context_Type);

   type Router_Type is new Ada.Finalization.Limited_Controlled with record
      Route : aliased Path_Node_Type (Len => 0);
   end record;

   --  Release the storage held by the router.
   overriding
   procedure Finalize (Router : in out Router_Type);

end ASF.Routes;

-----------------------------------------------------------------------
--  asf-routes -- Request routing
--  Copyright (C) 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.Finalization;

with Util.Beans.Basic;
with EL.Expressions;
with EL.Contexts;

package ASF.Routes is

   type Route_Type is limited interface;
   type Route_Type_Access is access all Route_Type'Class;

   --  The <tt>Route_Context_Type</tt> defines the context information after a path
   --  has been routed.
   type Route_Context_Type is tagged limited private;

   --  Get path information after the routing.
   function Get_Path_Info (Context : in Route_Context_Type) return String;

   --  Return the route associated with the resolved route context.
   function Get_Route (Context : in Route_Context_Type) return Route_Type_Access;

   --  Inject the parameters that have been extracted from the path according
   --  to the selected route.
   procedure Inject_Parameters (Context   : in Route_Context_Type;
                                Into      : in out Util.Beans.Basic.Bean'Class;
                                ELContext : in EL.Contexts.ELContext'Class);

   --  The <tt>Router_Type</tt> registers the different routes with their rules and
   --  resolves a path into a route context information.
   type Router_Type is new Ada.Finalization.Limited_Controlled with private;
   type Router_Type_Access is access all Router_Type'Class;

   --  Add a route associated with the given path pattern.  The pattern is split into components.
   --  Some path components can be a fixed string (/home) and others can be variable.
   --  When a path component is variable, the value can be retrieved from the route context.
   procedure Add_Route (Router    : in out Router_Type;
                        Pattern   : in String;
                        To        : in Route_Type_Access;
                        ELContext : in EL.Contexts.ELContext'Class);

   --  Build the route context from the given path by looking at the different routes registered
   --  in the router with <tt>Add_Route</tt>.
   procedure Find_Route (Router  : in Router_Type;
                         Path    : in String;
                         Context : in out Route_Context_Type'Class);

   --  Walk the routes that have been added by <tt>Add_Route</tt> and call the <tt>Process</tt>
   --  procedure with each path pattern and route object.
   procedure Iterate (Router  : in Router_Type;
                      Process : not null access procedure (Pattern : in String;
                                                           Route   : in Route_Type_Access));

private

   type String_Access is access all String;

   type Route_Node_Type;
   type Route_Node_Access is access all Route_Node_Type'Class;

   type Route_Match_Type is (NO_MATCH, MAYBE_MATCH, WILDCARD_MATCH, YES_MATCH);

   type Route_Node_Type is abstract tagged limited record
      Next_Route : Route_Node_Access;
      Children   : Route_Node_Access;
      Route      : Route_Type_Access;
   end record;

   --  Inject the parameter that was extracted from the path.
   procedure Inject_Parameter (Node      : in Route_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class) is null;

   --  Check if the route node accepts the given path component.
   function Matches (Node    : in Route_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type is abstract;

   --  Return the component path pattern that this route node represents.
   --  Example: 'index.html', '#{user.id}', ':id'
   function Get_Pattern (Node : in Route_Node_Type) return String is abstract;

   --  Find recursively a match on the given route sub-tree.  The match must start at the position
   --  <tt>First</tt> in the path up to the last path position.  While the path components are
   --  checked, the route context is populated with variable components.  When the full path
   --  matches, <tt>YES_MATCH</tt> is returned in the context gets the route instance.
   procedure Find_Match (Node    : in Route_Node_Type;
                         Path    : in String;
                         First   : in Natural;
                         Match   : out Route_Match_Type;
                         Context : in out Route_Context_Type'Class);

   --  Walk the routes that have been added by <tt>Add_Route</tt> and call the <tt>Process</tt>
   --  procedure with each path pattern and route object.
   procedure Iterate (Node    : in Route_Node_Type;
                      Path    : in String;
                      Process : not null access procedure (Pattern : in String;
                                                           Route   : in Route_Type_Access));

   --  A fixed path component identification.
   type Path_Node_Type (Len : Natural) is new Route_Node_Type with record
      Name : aliased String (1 .. Len);
   end record;
   type Path_Node_Access is access all Path_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns YES_MATCH if the name corresponds exactly to the node's name.
   overriding
   function Matches (Node    : in Path_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, 'Name').
   overriding
   function Get_Pattern (Node : in Path_Node_Type) return String;

   --  A variable path component whose value is injected in an Ada bean using the EL expression.
   --  The route node is created each time an EL expression is found in the route pattern.
   --  Example: /home/#{user.id}/index.html
   --  In this example, the EL expression refers to <tt>user.id</tt>.
   type EL_Node_Type is new Route_Node_Type with record
      Value : EL.Expressions.Value_Expression;
   end record;
   type EL_Node_Access is access all EL_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in EL_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, the EL expr).
   overriding
   function Get_Pattern (Node : in EL_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in EL_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class);

   --  A variable path component which can be injected in an Ada bean.
   --  Example: /home/:id/view.html
   --  The path component represented by <tt>:id</tt> is injected in the Ada bean object
   --  passed to the <tt>Inject_Parameters</tt> procedure.
   type Param_Node_Type (Len : Natural) is new Route_Node_Type with record
      Name : String (1 .. Len);
   end record;
   type Param_Node_Access is access all Param_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in Param_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, Name).
   overriding
   function Get_Pattern (Node : in Param_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in Param_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class);

   type Extension_Node_Type (Len : Natural) is new Route_Node_Type with record
      Ext : String (1 .. Len);
   end record;
   type Extension_Node_Access is access all Extension_Node_Type'Class;

   --  Check if the route node accepts the given extension.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in Extension_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, *.Ext).
   overriding
   function Get_Pattern (Node : in Extension_Node_Type) return String;

   type Wildcard_Node_Type is new Route_Node_Type with null record;
   type Wildcard_Node_Access is access all Wildcard_Node_Type'Class;

   --  Check if the route node accepts the given extension.
   --  Returns WILDCARD_MATCH.
   overriding
   function Matches (Node    : in Wildcard_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, *).
   overriding
   function Get_Pattern (Node : in Wildcard_Node_Type) return String;

   --  Describes a variable path component whose value must be injected in an Ada bean.
   type Route_Param_Type is limited record
      Route : Route_Node_Access;
      First : Natural := 0;
      Last  : Natural := 0;
   end record;

   type Route_Param_Array is array (Positive range <>) of Route_Param_Type;

   MAX_ROUTE_PARAMS : constant Positive := 10;

   type Route_Context_Type is limited new Ada.Finalization.Limited_Controlled with record
      Route  : Route_Type_Access;
      Path   : String_Access;
      Params : Route_Param_Array (1 .. MAX_ROUTE_PARAMS);
      Count  : Natural := 0;
   end record;

   --  Release the storage held by the route context.
   overriding
   procedure Finalize (Context : in out Route_Context_Type);

   type Router_Type is new Ada.Finalization.Limited_Controlled with record
      Route : aliased Path_Node_Type (Len => 0);
   end record;

   --  Release the storage held by the router.
   overriding
   procedure Finalize (Router : in out Router_Type);

end ASF.Routes;

Define the Wildcard_Node_Type node to represent a wildcard node (such as /admin/*)


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

with Ada.Finalization;

with Util.Beans.Basic;
with Util.Refs;
with EL.Expressions;
with EL.Contexts;

package ASF.Routes is

   type Route_Type is abstract new Util.Refs.Ref_Entity with null record;
   type Route_Type_Access is access all Route_Type'Class;

   --  function Duplicate (Route : in Route_Type) return Route_Type_Access is abstract;

   package Route_Type_Refs is
     new Util.Refs.Indefinite_References (Element_Type => Route_Type'Class,
                                          Element_Access => Route_Type_Access);

   subtype Route_Type_Ref is Route_Type_Refs.Ref;
   --  subtype Route_Type_Access is Route_Type_Refs.Element_Access;

   No_Parameter : exception;

   type Path_Mode is (FULL, PREFIX, SUFFIX);

   --  The <tt>Route_Context_Type</tt> defines the context information after a path
   --  has been routed.
   type Route_Context_Type is tagged limited private;

   --  Get path information after the routing.
   function Get_Path (Context : in Route_Context_Type;
                      Mode    : in Path_Mode := FULL) return String;

   --  Get the path parameter value for the given parameter index.
   --  The <tt>No_Parameter</tt> exception is raised if the parameter does not exist.
   function Get_Parameter (Context : in Route_Context_Type;
                           Index   : in Positive) return String;

   --  Get the number of path parameters that were extracted for the route.
   function Get_Parameter_Count (Context : in Route_Context_Type) return Natural;

   --  Return the position of the variable part of the path.
   --  If the URI matches a wildcard pattern, the position of the last '/' in the wildcard pattern
   --  is returned.
   function Get_Path_Pos (Context : in Route_Context_Type) return Natural;

   --  Return the route associated with the resolved route context.
   function Get_Route (Context : in Route_Context_Type) return Route_Type_Access;

   --  Change the context to use a new route.
   procedure Change_Route (Context : in out Route_Context_Type;
                           To      : in Route_Type_Access);

   --  Inject the parameters that have been extracted from the path according
   --  to the selected route.
   procedure Inject_Parameters (Context   : in Route_Context_Type;
                                Into      : in out Util.Beans.Basic.Bean'Class;
                                ELContext : in EL.Contexts.ELContext'Class);

   --  The <tt>Router_Type</tt> registers the different routes with their rules and
   --  resolves a path into a route context information.
   type Router_Type is new Ada.Finalization.Limited_Controlled with private;
   type Router_Type_Access is access all Router_Type'Class;

   --  Add a route associated with the given path pattern.  The pattern is split into components.
   --  Some path components can be a fixed string (/home) and others can be variable.
   --  When a path component is variable, the value can be retrieved from the route context.
   --  Once the route path is created, the <tt>Process</tt> procedure is called with the route
   --  reference.
   procedure Add_Route (Router    : in out Router_Type;
                        Pattern   : in String;
                        ELContext : in EL.Contexts.ELContext'Class;
                        Process   : not null access procedure (Route : in out Route_Type_Ref));

   --  Build the route context from the given path by looking at the different routes registered
   --  in the router with <tt>Add_Route</tt>.
   procedure Find_Route (Router  : in Router_Type;
                         Path    : in String;
                         Context : in out Route_Context_Type'Class);

   --  Walk the routes that have been added by <tt>Add_Route</tt> and call the <tt>Process</tt>
   --  procedure with each path pattern and route object.
   procedure Iterate (Router  : in Router_Type;
                      Process : not null access procedure (Pattern : in String;
                                                           Route   : in Route_Type_Access));

private

   type String_Access is access all String;

   type Route_Node_Type;
   type Route_Node_Access is access all Route_Node_Type'Class;

   --  Describes a variable path component whose value must be injected in an Ada bean.
   type Route_Param_Type is limited record
      Route : Route_Node_Access;
      First : Natural := 0;
      Last  : Natural := 0;
   end record;

   type Route_Param_Array is array (Positive range <>) of Route_Param_Type;

   type Route_Match_Type is (NO_MATCH, MAYBE_MATCH, WILDCARD_MATCH, EXT_MATCH, YES_MATCH);

   type Route_Node_Type is abstract tagged limited record
      Next_Route : Route_Node_Access;
      Children   : Route_Node_Access;
      Route      : Route_Type_Ref;
   end record;

   --  Inject the parameter that was extracted from the path.
   procedure Inject_Parameter (Node      : in Route_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class) is null;

   --  Check if the route node accepts the given path component.
   function Matches (Node    : in Route_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type is abstract;

   --  Return the component path pattern that this route node represents.
   --  Example: 'index.html', '#{user.id}', ':id'
   function Get_Pattern (Node : in Route_Node_Type) return String is abstract;

   --  Return the position of the variable part of the path.
   --  If the URI matches a wildcard pattern, the position of the last '/' in the wildcard pattern
   --  is returned.
   function Get_Path_Pos (Node  : in Route_Node_Type;
                          Param : in Route_Param_Type) return Natural;

   --  Find recursively a match on the given route sub-tree.  The match must start at the position
   --  <tt>First</tt> in the path up to the last path position.  While the path components are
   --  checked, the route context is populated with variable components.  When the full path
   --  matches, <tt>YES_MATCH</tt> is returned in the context gets the route instance.
   procedure Find_Match (Node    : in Route_Node_Type;
                         Path    : in String;
                         First   : in Natural;
                         Match   : out Route_Match_Type;
                         Context : in out Route_Context_Type'Class);

   --  Walk the routes that have been added by <tt>Add_Route</tt> and call the <tt>Process</tt>
   --  procedure with each path pattern and route object.
   procedure Iterate (Node    : in Route_Node_Type;
                      Path    : in String;
                      Process : not null access procedure (Pattern : in String;
                                                           Route   : in Route_Type_Access));

   --  A fixed path component identification.
   type Path_Node_Type (Len : Natural) is new Route_Node_Type with record
      Name : aliased String (1 .. Len);
   end record;
   type Path_Node_Access is access all Path_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns YES_MATCH if the name corresponds exactly to the node's name.
   overriding
   function Matches (Node    : in Path_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, 'Name').
   overriding
   function Get_Pattern (Node : in Path_Node_Type) return String;

   --  A variable path component whose value is injected in an Ada bean using the EL expression.
   --  The route node is created each time an EL expression is found in the route pattern.
   --  Example: /home/#{user.id}/index.html
   --  In this example, the EL expression refers to <tt>user.id</tt>.
   type EL_Node_Type is new Route_Node_Type with record
      Value : EL.Expressions.Value_Expression;
   end record;
   type EL_Node_Access is access all EL_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in EL_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, the EL expr).
   overriding
   function Get_Pattern (Node : in EL_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in EL_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class);

   --  A variable path component which can be injected in an Ada bean.
   --  Example: /home/:id/view.html
   --  The path component represented by <tt>:id</tt> is injected in the Ada bean object
   --  passed to the <tt>Inject_Parameters</tt> procedure.
   type Param_Node_Type (Len : Natural) is new Route_Node_Type with record
      Name : String (1 .. Len);
   end record;
   type Param_Node_Access is access all Param_Node_Type'Class;

   --  Check if the route node accepts the given path component.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in Param_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, Name).
   overriding
   function Get_Pattern (Node : in Param_Node_Type) return String;

   --  Inject the parameter that was extracted from the path.
   overriding
   procedure Inject_Parameter (Node      : in Param_Node_Type;
                               Param     : in String;
                               Into      : in out Util.Beans.Basic.Bean'Class;
                               ELContext : in EL.Contexts.ELContext'Class);

   type Extension_Node_Type (Len : Natural) is new Route_Node_Type with record
      Ext : String (1 .. Len);
   end record;
   type Extension_Node_Access is access all Extension_Node_Type'Class;

   --  Check if the route node accepts the given extension.
   --  Returns MAYBE_MATCH.
   overriding
   function Matches (Node    : in Extension_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, *.Ext).
   overriding
   function Get_Pattern (Node : in Extension_Node_Type) return String;

   type Wildcard_Node_Type is new Route_Node_Type with null record;
   type Wildcard_Node_Access is access all Wildcard_Node_Type'Class;

   --  Check if the route node accepts the given extension.
   --  Returns WILDCARD_MATCH.
   overriding
   function Matches (Node    : in Wildcard_Node_Type;
                     Name    : in String;
                     Is_Last : in Boolean) return Route_Match_Type;

   --  Return the component path pattern that this route node represents (ie, *).
   overriding
   function Get_Pattern (Node : in Wildcard_Node_Type) return String;

   --  Return the position of the variable part of the path.
   --  If the URI matches a wildcard pattern, the position of the last '/' in the wildcard pattern
   --  is returned.
   overriding
   function Get_Path_Pos (Node  : in Wildcard_Node_Type;
                          Param : in Route_Param_Type) return Natural;

   MAX_ROUTE_PARAMS : constant Positive := 10;

   type Route_Context_Type is limited new Ada.Finalization.Limited_Controlled with record
      Route  : Route_Type_Access;
      Path   : String_Access;
      Params : Route_Param_Array (1 .. MAX_ROUTE_PARAMS);
      Count  : Natural := 0;
   end record;

   --  Release the storage held by the route context.
   overriding
   procedure Finalize (Context : in out Route_Context_Type);

   type Router_Type is new Ada.Finalization.Limited_Controlled with record
      Route : aliased Path_Node_Type (Len => 0);
   end record;

   --  Release the storage held by the router.
   overriding
   procedure Finalize (Router : in out Router_Type);

   --  Insert the route node at the correct place in the children list
   --  according to the rule kind.
   procedure Insert (Parent : in Route_Node_Access;
                     Node   : in Route_Node_Access;
                     Kind   : in Route_Match_Type);

end ASF.Routes;

-----------------------------------------------------------------------
--  asf-routes -- Request routing
--  Copyright (C) 2015, 2016, 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.Finalization;
with Ada.Strings.Unbounded;

with Util.Beans.Basic;
with Util.Refs;
with EL.Expressions;
with EL.Contexts;
with Servlet.Routes.Servlets;

package ASF.Routes is

   type Faces_Route_Type is new Servlet.Routes.Servlets.Servlet_Route_Type with record
      View    : Ada.Strings.Unbounded.Unbounded_String;
   end record;
   type Faces_Route_Type_Access is access all Faces_Route_Type'Class;

   subtype Route_Type is Servlet.Routes.Route_Type;
   subtype Route_Type_Access is Servlet.Routes.Route_Type_Access;
   subtype Route_Type_Ref is Servlet.Routes.Route_Type_Ref;
   --  subtype Route_Type_Access is Route_Type_Refs.Element_Access;

   subtype Route_Context_Type is Servlet.Routes.Route_Context_Type;

   package Route_Type_Refs renames Servlet.Routes.Route_Type_Refs;

end ASF.Routes;

Package ASF.Routes moved to Servlet.Routes


-----------------------------------------------------------------------
--  Util.Files -- Various File Utility Packages
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Util.Strings.Maps;
with Util.Strings.Vectors;
package Util.Files is

   use Ada.Strings.Unbounded;

   subtype Direction is Ada.Strings.Direction;

   --  Read a complete file into a string.
   --  The Max_Size parameter indicates the maximum size that is read.
   procedure Read_File (Path     : in String;
                        Into     : out Unbounded_String;
                        Max_Size : in Natural := 0);

   --  Read the file with the given path, one line at a time and execute the Process
   --  procedure with each line as argument.
   procedure Read_File (Path     : in String;
                        Process  : not null access procedure (Line : in String));

   --  Read the file with the given path, one line at a time and append each line to
   --  the Into vector.
   procedure Read_File (Path  : in String;
                        Into  : in out Util.Strings.Vectors.Vector);

   --  Save the string into a file creating the file if necessary
   procedure Write_File (Path    : in String;
                         Content : in String);

   --  Save the string into a file creating the file if necessary
   procedure Write_File (Path    : in String;
                         Content : in Unbounded_String);

   --  Iterate over the search directories defined in Path and execute
   --  Process with each directory until it returns True in Done
   --  or the last search directory is found.  Each search directory
   --  is separated by ';' (yes, even on Unix).  When Going is set to Backward, the
   --  directories are searched in reverse order.
   procedure Iterate_Path (Path     : in String;
                           Process  : not null access procedure (Dir  : in String;
                                                                 Done : out Boolean);
                           Going    : in Direction := Ada.Strings.Forward);

   --  Iterate over the search directories defined in Path and search
   --  for files matching the pattern defined by Pattern.  For each file,
   --  execute Process with the file basename and the full file path.
   --  Stop iterating when the Process procedure returns True.
   --  Each search directory is separated by ';'.  When Going is set to Backward, the
   --  directories are searched in reverse order.
   procedure Iterate_Files_Path (Pattern  : in String;
                                 Path     : in String;
                                 Process  : not null access procedure (Name : in String;
                                                                       File : in String;
                                                                       Done : out Boolean);
                                 Going    : in Direction := Ada.Strings.Forward);

   --  Find the file in one of the search directories.  Each search directory
   --  is separated by ';' (yes, even on Unix).
   --  Returns the path to be used for reading the file.
   function Find_File_Path (Name  : String;
                            Paths : String) return String;

   --  Find the files which match the pattern in the directories specified in the
   --  search path Path.  Each search directory is separated by ';'.
   --  File names are added to the string set in Into.
   procedure Find_Files_Path (Pattern : in String;
                              Path    : in String;
                              Into    : in out Util.Strings.Maps.Map);

   --  Returns the name of the external file with the specified directory
   --  and the name.  Unlike the Ada.Directories.Compose, the name can represent
   --  a relative path and thus include directory separators.
   function Compose (Directory : in String;
                     Name      : in String) return String;

   --  Compose an existing path by adding the specified name to each path component
   --  and return a new paths having only existing directories.  Each directory is
   --  separated by ';'.
   --  If the composed path exists, it is added to the result path.
   --  Example:
   --    paths = 'web;regtests'  name = 'info'
   --    result = 'web/info;regtests/info'
   --  Returns the composed path.
   function Compose_Path (Paths : in String;
                          Name  : in String) return String;

   --  Returns a relative path whose origin is defined by From and which refers
   --  to the absolute path referenced by To.  Both From and To are
   --  assumed to be absolute pathes.  Returns the absolute path To if the relative
   --  path could not be found.  Both paths must have at least one root component in common.
   function Get_Relative_Path (From : in String;
                               To   : in String) return String;

end Util.Files;

-----------------------------------------------------------------------
--  util-files -- Various File Utility Packages
--  Copyright (C) 2001, 2002, 2003, 2009, 2010, 2011, 2012, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Strings.Unbounded;
with Util.Strings.Maps;
with Util.Strings.Vectors;
package Util.Files is

   use Ada.Strings.Unbounded;

   subtype Direction is Ada.Strings.Direction;

   --  Read a complete file into a string.
   --  The Max_Size parameter indicates the maximum size that is read.
   procedure Read_File (Path     : in String;
                        Into     : out Unbounded_String;
                        Max_Size : in Natural := 0);

   --  Read the file with the given path, one line at a time and execute the Process
   --  procedure with each line as argument.
   procedure Read_File (Path     : in String;
                        Process  : not null access procedure (Line : in String));

   --  Read the file with the given path, one line at a time and append each line to
   --  the Into vector.
   procedure Read_File (Path  : in String;
                        Into  : in out Util.Strings.Vectors.Vector);

   --  Save the string into a file creating the file if necessary
   procedure Write_File (Path    : in String;
                         Content : in String);

   --  Save the string into a file creating the file if necessary
   procedure Write_File (Path    : in String;
                         Content : in Unbounded_String);

   --  Iterate over the search directories defined in Path and execute
   --  Process with each directory until it returns True in Done
   --  or the last search directory is found.  Each search directory
   --  is separated by ';' (yes, even on Unix).  When Going is set to Backward, the
   --  directories are searched in reverse order.
   procedure Iterate_Path (Path     : in String;
                           Process  : not null access procedure (Dir  : in String;
                                                                 Done : out Boolean);
                           Going    : in Direction := Ada.Strings.Forward);

   --  Iterate over the search directories defined in Path and search
   --  for files matching the pattern defined by Pattern.  For each file,
   --  execute Process with the file basename and the full file path.
   --  Stop iterating when the Process procedure returns True.
   --  Each search directory is separated by ';'.  When Going is set to Backward, the
   --  directories are searched in reverse order.
   procedure Iterate_Files_Path (Pattern  : in String;
                                 Path     : in String;
                                 Process  : not null access procedure (Name : in String;
                                                                       File : in String;
                                                                       Done : out Boolean);
                                 Going    : in Direction := Ada.Strings.Forward);

   --  Find the file in one of the search directories.  Each search directory
   --  is separated by ';' (yes, even on Unix).
   --  Returns the path to be used for reading the file.
   function Find_File_Path (Name  : String;
                            Paths : String) return String;

   --  Find the files which match the pattern in the directories specified in the
   --  search path Path.  Each search directory is separated by ';'.
   --  File names are added to the string set in Into.
   procedure Find_Files_Path (Pattern : in String;
                              Path    : in String;
                              Into    : in out Util.Strings.Maps.Map);

   --  Returns the name of the external file with the specified directory
   --  and the name.  Unlike the Ada.Directories.Compose, the name can represent
   --  a relative path and thus include directory separators.
   function Compose (Directory : in String;
                     Name      : in String) return String;

   --  Compose an existing path by adding the specified name to each path component
   --  and return a new paths having only existing directories.  Each directory is
   --  separated by ';'.
   --  If the composed path exists, it is added to the result path.
   --  Example:
   --    paths = 'web;regtests'  name = 'info'
   --    result = 'web/info;regtests/info'
   --  Returns the composed path.
   function Compose_Path (Paths : in String;
                          Name  : in String) return String;

   --  Returns a relative path whose origin is defined by From and which refers
   --  to the absolute path referenced by To.  Both From and To are
   --  assumed to be absolute pathes.  Returns the absolute path To if the relative
   --  path could not be found.  Both paths must have at least one root component in common.
   function Get_Relative_Path (From : in String;
                               To   : in String) return String;

end Util.Files;

Update the header and invert some if condition as per AdaControl recommendation


-----------------------------------------------------------------------
--  asf-servlets-rest -- REST servlet
--  Copyright (C) 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 ASF.Rest;
with ASF.Applications;
with ASF.Streams.JSON;
with Util.Streams.Texts;
with Util.Serialize.IO.JSON;
with ASF.Routes.Servlets.Rest;
package body ASF.Servlets.Rest is

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Rest_Servlet;
                         Context : in Servlet_Registry'Class) is
      pragma Unreferenced (Context);

      Ctx : constant Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if Ctx.all in ASF.Applications.Main.Application'Class then
         Server.App := ASF.Applications.Main.Application'Class (Ctx.all)'Unchecked_Access;
      end if;
   end Initialize;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   overriding
   procedure Service (Server   : in Rest_Servlet;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
      Method : constant String := Request.Get_Method;
   begin
      if Method = "GET" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.GET, Request, Response);

      elsif Method = "POST" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "PUT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.PUT, Request, Response);

      elsif Method = "DELETE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.DELETE, Request, Response);

      elsif Method = "HEAD" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "OPTIONS" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.HEAD, Request, Response);

      elsif Method = "TRACE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.TRACE, Request, Response);

      elsif Method = "CONNECT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.CONNECT, Request, Response);

      else
         Response.Send_Error (Responses.SC_NOT_IMPLEMENTED);
      end if;
   end Service;

   procedure Dispatch (Server   : in Rest_Servlet;
                       Method   : in ASF.Rest.Method_Type;
                       Request  : in out Requests.Request'Class;
                       Response : in out Responses.Response'Class) is
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Routes.Servlets.Rest.API_Route_Type;
      use type ASF.Rest.Descriptor_Access;

      Route  : constant ASF.Routes.Route_Type_Access := Request.Get_Route;
   begin
      if Route = null or else not (Route.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      declare
         Api    : constant access ASF.Routes.Servlets.Rest.API_Route_Type
           := ASF.Routes.Servlets.Rest.API_Route_Type (Route.all)'Access;
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Stream : ASF.Streams.JSON.Print_Stream;
      begin
         if Api.Descriptors (Method) = null then
            Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
            return;
         end if;
         ASF.Streams.JSON.Initialize (Stream, Output);
         Api.Descriptors (Method).Dispatch (Request, Response, Stream);
      end;
   end Dispatch;

   function Create_Route (Registry : in ASF.Servlets.Servlet_Registry;
                          Name     : in String)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Pos    : constant Servlet_Maps.Cursor := Registry.Servlets.Find (Name);
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      if not Servlet_Maps.Has_Element (Pos) then
         --  Log.Error ("No servlet {0}", Name);
         raise Servlet_Error with "No servlet " & Name;
      end if;
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet_Maps.Element (Pos);
      return Result;
   end Create_Route;

end ASF.Servlets.Rest;

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

with ASF.Applications;
with ASF.Streams.JSON;
with Util.Streams.Texts;
with Util.Serialize.IO.JSON;
package body ASF.Servlets.Rest is

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out Rest_Servlet;
                         Context : in Servlet_Registry'Class) is
      pragma Unreferenced (Context);

      Ctx : constant Servlet_Registry_Access := Server.Get_Servlet_Context;
   begin
      if Ctx.all in ASF.Applications.Main.Application'Class then
         Server.App := ASF.Applications.Main.Application'Class (Ctx.all)'Unchecked_Access;
      end if;
   end Initialize;

   --  ------------------------------
   --  Receives standard HTTP requests from the public service method and dispatches
   --  them to the Do_XXX methods defined in this class. This method is an HTTP-specific
   --  version of the Servlet.service(Request, Response) method. There's no need
   --  to override this method.
   --  ------------------------------
   overriding
   procedure Service (Server   : in Rest_Servlet;
                      Request  : in out Requests.Request'Class;
                      Response : in out Responses.Response'Class) is
      Method : constant String := Request.Get_Method;
   begin
      if Method = "GET" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.GET, Request, Response);

      elsif Method = "POST" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "PUT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.PUT, Request, Response);

      elsif Method = "DELETE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.DELETE, Request, Response);

      elsif Method = "HEAD" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.POST, Request, Response);

      elsif Method = "OPTIONS" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.HEAD, Request, Response);

      elsif Method = "TRACE" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.TRACE, Request, Response);

      elsif Method = "CONNECT" then
         Rest_Servlet'Class (Server).Dispatch (ASF.Rest.CONNECT, Request, Response);

      else
         Response.Send_Error (Responses.SC_NOT_IMPLEMENTED);
      end if;
   end Service;

   procedure Dispatch (Server   : in Rest_Servlet;
                       Method   : in ASF.Rest.Method_Type;
                       Request  : in out Requests.Request'Class;
                       Response : in out Responses.Response'Class) is
      pragma Unreferenced (Server);
      use type ASF.Routes.Route_Type_Access;
      use type ASF.Routes.Servlets.Rest.API_Route_Type;
      use type ASF.Rest.Descriptor_Access;

      Route  : constant ASF.Routes.Route_Type_Access := Request.Get_Route;
   begin
      if Route = null or else not (Route.all in ASF.Routes.Servlets.Rest.API_Route_Type'Class) then
         Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
         return;
      end if;
      declare
         Api    : constant access ASF.Routes.Servlets.Rest.API_Route_Type
           := ASF.Routes.Servlets.Rest.API_Route_Type (Route.all)'Access;
         Desc   : constant ASF.Rest.Descriptor_Access := Api.Descriptors (Method);
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Stream : ASF.Streams.JSON.Print_Stream;
      begin
         if Desc = null then
            Response.Set_Status (ASF.Responses.SC_NOT_FOUND);
            return;
         end if;
--         if not App.Has_Permission (Desc.Permission) then
--            Response.Set_Status (ASF.Responses.SC_FORBIDDEN);
--            return;
--         end if;
         ASF.Streams.JSON.Initialize (Stream, Output);
         Api.Descriptors (Method).Dispatch (Request, Response, Stream);
      end;
   end Dispatch;

   function Create_Route (Registry : in ASF.Servlets.Servlet_Registry;
                          Name     : in String)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Pos    : constant Servlet_Maps.Cursor := Registry.Servlets.Find (Name);
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      if not Servlet_Maps.Has_Element (Pos) then
         --  Log.Error ("No servlet {0}", Name);
         raise Servlet_Error with "No servlet " & Name;
      end if;
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet_Maps.Element (Pos);
      return Result;
   end Create_Route;

   --  Create a route for the REST API.
   function Create_Route (Servlet  : in ASF.Servlets.Servlet_Access)
                          return ASF.Routes.Servlets.Rest.API_Route_Type_Access is
      Result : ASF.Routes.Servlets.Rest.API_Route_Type_Access;
   begin
      Result := new ASF.Routes.Servlets.Rest.API_Route_Type;
      Result.Servlet := Servlet;
      return Result;
   end Create_Route;

end ASF.Servlets.Rest;

Implement the Create_Route function

Implement the Create_Route function