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

with Ada.Interrupts.Names;
with Ada.Unchecked_Conversion;

with System;         use System;

with STM32_SVD.LTDC; use STM32_SVD.LTDC;
with STM32_SVD.RCC;  use STM32_SVD.RCC;

package body STM32.LTDC is

   pragma Warnings (Off, "* is not referenced");
   type LCD_Polarity is
     (Polarity_Active_Low,
      Polarity_Active_High) with Size => 1;
   type LCD_PC_Polarity is
     (Input_Pixel_Clock,
      Inverted_Input_Pixel_Clock) with Size => 1;
   pragma Warnings (On, "* is not referenced");

   function To_Bool is new Ada.Unchecked_Conversion (LCD_Polarity, Boolean);
   function To_Bool is new Ada.Unchecked_Conversion (LCD_PC_Polarity, Boolean);

   --  Extracted from STM32F429x.LTDC
   type Layer_Type is record
      LCR        : L1CR_Register;
      --  Layerx Control Register

      LWHPCR     : L1WHPCR_Register;
      --  Layerx Window Horizontal Position Configuration Register

      LWVPCR     : L1WVPCR_Register;
      --  Layerx Window Vertical Position Configuration Register

      LCKCR      : L1CKCR_Register;
      --  Layerx Color Keying Configuration Register

      LPFCR      : L1PFCR_Register;
      --  Layerx Pixel Format Configuration Register

      LCACR      : L1CACR_Register;
      --  Layerx Constant Alpha Configuration Register

      LDCCR      : L1DCCR_Register;
      --  Layerx Default Color Configuration Register

      LBFCR      : L1BFCR_Register;
      --  Layerx Blending Factors Configuration Register

      Reserved_0 : Word;
      Reserved_1 : Word;

      LCFBAR     : Word;
      --  Layerx Color Frame Buffer Address Register

      LCFBLR     : L1CFBLR_Register;
      --  Layerx Color Frame Buffer Length Register

      LCFBLNR    : L1CFBLNR_Register;
      --  Layerx ColorFrame Buffer Line Number Register

      Reserved_2 : Word;
      Reserved_3 : Word;
      Reserved_4 : Word;

      LCLUTWR    : L1CLUTWR_Register;
      --  Layerx CLUT Write Register
   end record with Volatile;

   for Layer_Type use record
      LCR        at  0 range 0 .. 31;
      LWHPCR     at  4 range 0 .. 31;
      LWVPCR     at  8 range 0 .. 31;
      LCKCR      at 12 range 0 .. 31;
      LPFCR      at 16 range 0 .. 31;
      LCACR      at 20 range 0 .. 31;
      LDCCR      at 24 range 0 .. 31;
      LBFCR      at 28 range 0 .. 31;
      Reserved_0 at 32 range 0 .. 31;
      Reserved_1 at 36 range 0 .. 31;
      LCFBAR     at 40 range 0 .. 31;
      LCFBLR     at 44 range 0 .. 31;
      LCFBLNR    at 48 range 0 .. 31;
      Reserved_2 at 52 range 0 .. 31;
      Reserved_3 at 56 range 0 .. 31;
      Reserved_4 at 60 range 0 .. 31;
      LCLUTWR    at 64 range 0 .. 31;
   end record;
   type Layer_Access is access all Layer_Type;

   BF1_Constant_Alpha : constant := 2#100#;
   BF2_Constant_Alpha : constant := 2#101#;
   BF1_Pixel_Alpha    : constant := 2#110#;
   BF2_Pixel_Alpha    : constant := 2#111#;

   G_Layer1_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L1CR'Address;
   G_Layer2_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L2CR'Address;

   function Get_Layer (Layer : LCD_Layer) return Layer_Access;
   --  Retrieve the layer's registers

   protected Sync is
      --  Apply pending buffers on Vertical Sync. Caller must call Wait
      --  afterwards.
      procedure Apply_On_VSync;

      --  Wait for an interrupt.
      entry Wait;

      procedure Interrupt;
      pragma Attach_Handler
        (Interrupt, Ada.Interrupts.Names.LCD_TFT_Interrupt);

   private
      Not_Pending : Boolean := True;
   end Sync;

   ----------
   -- Sync --
   ----------

   protected body Sync is

      ----------
      -- Wait --
      ----------

      entry Wait when Not_Pending is
      begin
         null;
      end Wait;

      --------------------
      -- Apply_On_VSync --
      --------------------

      procedure Apply_On_VSync is
      begin
         Not_Pending := False;
         --  Enable the Register Refresh interrupt
         LTDC_Periph.IER.RRIE := True;
         --  And tell the LTDC to apply the layer registers on refresh
         LTDC_Periph.SRCR.VBR := True;
      end Apply_On_VSync;

      ---------------
      -- Interrupt --
      ---------------

      procedure Interrupt
      is
      begin
         if LTDC_Periph.ISR.RRIF then
            LTDC_Periph.IER.RRIE := False;
            LTDC_Periph.ICR.CRRIF  := True;

            Not_Pending := True;
         end if;
      end Interrupt;
   end Sync;

   ---------------
   -- Get_Layer --
   ---------------

   function Get_Layer (Layer : LCD_Layer) return Layer_Access is
   begin
      if Layer = Layer1 then
         return G_Layer1_Reg'Access;
      else
         return G_Layer2_Reg'Access;
      end if;
   end Get_Layer;

   -------------------
   -- Reload_Config --
   -------------------

   procedure Reload_Config
     (Immediate : Boolean := False)
   is
   begin
      if Immediate then
         LTDC_Periph.SRCR.IMR := True;

         loop
            exit when not LTDC_Periph.SRCR.IMR;
         end loop;
      else
         Sync.Apply_On_VSync;
         Sync.Wait;
      end if;
   end Reload_Config;

   ---------------------
   -- Set_Layer_State --
   ---------------------

   procedure Set_Layer_State
     (Layer   : LCD_Layer;
      Enabled : Boolean)
   is
      L   : constant Layer_Access := Get_Layer (Layer);
   begin
      if L.LCR.LEN /= Enabled then
         L.LCR.LEN := Enabled;
         Reload_Config (Immediate => True);
      end if;
   end Set_Layer_State;

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

   procedure Initialize
     (Width         : Positive;
      Height        : Positive;
      H_Sync        : Natural;
      H_Back_Porch  : Natural;
      H_Front_Porch : Natural;
      V_Sync        : Natural;
      V_Back_Porch  : Natural;
      V_Front_Porch : Natural;
      PLLSAI_N      : UInt9;
      PLLSAI_R      : UInt3;
      DivR          : Natural)
   is
      DivR_Val : PLLSAI_DivR;

   begin
      if Initialized then
         return;
      end if;

      RCC_Periph.APB2ENR.LTDCEN := True;

      LTDC_Periph.GCR.VSPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.HSPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.DEPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.PCPOL := To_Bool (Inverted_Input_Pixel_Clock);

      if DivR = 2 then
         DivR_Val := PLLSAI_DIV2;
      elsif DivR = 4 then
         DivR_Val := PLLSAI_DIV4;
      elsif DivR = 8 then
         DivR_Val := PLLSAI_DIV8;
      elsif DivR = 16 then
         DivR_Val := PLLSAI_DIV16;
      else
         raise Constraint_Error with "Invalid DivR value: 2, 4, 8, 16 allowed";
      end if;

      Disable_PLLSAI;
      Set_PLLSAI_Factors
        (LCD  => PLLSAI_R,
         VCO  => PLLSAI_N,
         DivR => DivR_Val);
      Enable_PLLSAI;

      --  Synchronization size
      LTDC_Periph.SSCR :=
        (HSW => SSCR_HSW_Field (H_Sync - 1),
         VSH => SSCR_VSH_Field (V_Sync - 1),
         others => <>);

      --  Accumulated Back Porch
      LTDC_Periph.BPCR :=
        (AHBP => BPCR_AHBP_Field (H_Sync + H_Back_Porch - 1),
         AVBP => BPCR_AVBP_Field (V_Sync + V_Back_Porch - 1),
         others => <>);

      --  Accumulated Active Width/Height
      LTDC_Periph.AWCR :=
        (AAW => AWCR_AAW_Field (H_Sync + H_Back_Porch + Width - 1),
         AAH => AWCR_AAH_Field (V_Sync + V_Back_Porch + Height - 1),
         others => <>);

      --  VTotal Width/Height
      LTDC_Periph.TWCR :=
        (TOTALW =>
           TWCR_TOTALW_Field
             (H_Sync + H_Back_Porch + Width + H_Front_Porch - 1),
         TOTALH =>
           TWCR_TOTALH_Field
             (V_Sync + V_Back_Porch + Height + V_Front_Porch - 1),
         others => <>);

      --  Background color to black
      LTDC_Periph.BCCR.BC := 0;

      LTDC_Periph.GCR.LTDCEN := True;

      Set_Layer_State (Layer1, False);
      Set_Layer_State (Layer2, False);

      --  enable Dither
      LTDC_Periph.GCR.DEN := True;
   end Initialize;

   -----------
   -- Start --
   -----------

   procedure Start is
   begin
      LTDC_Periph.GCR.LTDCEN := True;
   end Start;

   ----------
   -- Stop --
   ----------

   procedure Stop is
   begin
      LTDC_Periph.GCR.LTDCEN := False;
   end Stop;

   -----------------
   -- Initialized --
   -----------------

   function Initialized return Boolean is
   begin
      return LTDC_Periph.GCR.LTDCEN;
   end Initialized;

   ----------------
   -- Layer_Init --
   ----------------

   procedure Layer_Init
     (Layer          : LCD_Layer;
      Config         : Pixel_Format;
      Buffer         : System.Address;
      X, Y           : Natural;
      W, H           : Positive;
      Constant_Alpha : Byte := 255;
      BF             : Blending_Factor := BF_Pixel_Alpha_X_Constant_Alpha)
   is
      L        : constant Layer_Access := Get_Layer (Layer);
      CFBL     : L1CFBLR_Register := L.LCFBLR;
   begin
      --  Horizontal start and stop = sync + Back Porch
      L.LWHPCR :=
        (WHSTPOS => L1WHPCR_WHSTPOS_Field (LTDC_Periph.BPCR.AHBP) + 1 +
             L1WHPCR_WHSTPOS_Field (X),
         WHSPPOS => L1WHPCR_WHSPPOS_Field (LTDC_Periph.BPCR.AHBP) +
             L1WHPCR_WHSPPOS_Field (X + W),
         others  => <>);

      --  Vertical start and stop
      L.LWVPCR :=
        (WVSTPOS => LTDC_Periph.BPCR.AVBP + 1 + UInt11 (Y),
         WVSPPOS => LTDC_Periph.BPCR.AVBP + UInt11 (Y + H),
         others  => <>);

      L.LPFCR.PF := Pixel_Format'Enum_Rep (Config);

      L.LCACR.CONSTA := Constant_Alpha;

      L.LDCCR := (others => 0);

      case BF is
         when BF_Constant_Alpha =>
            L.LBFCR.BF1 := BF1_Constant_Alpha;
            L.LBFCR.BF2 := BF2_Constant_Alpha;
         when BF_Pixel_Alpha_X_Constant_Alpha =>
            L.LBFCR.BF1 := BF1_Pixel_Alpha;
            L.LBFCR.BF2 := BF2_Pixel_Alpha;
      end case;

      CFBL.CFBLL := UInt13 (W * Bytes_Per_Pixel (Config)) + 3;
      CFBL.CFBP := UInt13 (W * Bytes_Per_Pixel (Config));
      L.LCFBLR := CFBL;

      L.LCFBLNR.CFBLNBR := UInt11 (H);

      Set_Frame_Buffer (Layer, Buffer);
      Set_Layer_State (Layer, True);
   end Layer_Init;

   ----------------------
   -- Set_Frame_Buffer --
   ----------------------

   procedure Set_Frame_Buffer
     (Layer : LCD_Layer; Addr : Frame_Buffer_Access)
   is
      function To_Word is new Ada.Unchecked_Conversion
        (Frame_Buffer_Access, Word);
   begin
      if Layer = Layer1 then
         LTDC_Periph.L1CFBAR := To_Word (Addr);
      else
         LTDC_Periph.L2CFBAR := To_Word (Addr);
      end if;
   end Set_Frame_Buffer;

   ----------------------
   -- Get_Frame_Buffer --
   ----------------------

   function Get_Frame_Buffer
     (Layer : LCD_Layer)
      return Frame_Buffer_Access
   is
      L : constant Layer_Access := Get_Layer (Layer);
      function To_FBA is new Ada.Unchecked_Conversion
        (Word, Frame_Buffer_Access);
   begin
      return To_FBA (L.LCFBAR);
   end Get_Frame_Buffer;

   --------------------
   -- Set_Background --
   --------------------

   procedure Set_Background (R, G, B : Byte) is
      RShift : constant Word := Shift_Left (Word (R), 16);
      GShift : constant Word := Shift_Left (Word (G), 8);
   begin
      LTDC_Periph.BCCR.BC :=
        UInt24 (RShift) or UInt24 (GShift) or UInt24 (B);
   end Set_Background;

end STM32.LTDC;

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

with Ada.Interrupts.Names;
with Ada.Unchecked_Conversion;

with System;         use System;

with STM32_SVD.LTDC; use STM32_SVD.LTDC;
with STM32_SVD.RCC;  use STM32_SVD.RCC;

package body STM32.LTDC is

   pragma Warnings (Off, "* is not referenced");
   type LCD_Polarity is
     (Polarity_Active_Low,
      Polarity_Active_High) with Size => 1;
   type LCD_PC_Polarity is
     (Input_Pixel_Clock,
      Inverted_Input_Pixel_Clock) with Size => 1;
   pragma Warnings (On, "* is not referenced");

   function To_Bool is new Ada.Unchecked_Conversion (LCD_Polarity, Boolean);
   function To_Bool is new Ada.Unchecked_Conversion (LCD_PC_Polarity, Boolean);

   --  Extracted from STM32F429x.LTDC
   type Layer_Type is record
      LCR        : L1CR_Register;
      --  Layerx Control Register

      LWHPCR     : L1WHPCR_Register;
      --  Layerx Window Horizontal Position Configuration Register

      LWVPCR     : L1WVPCR_Register;
      --  Layerx Window Vertical Position Configuration Register

      LCKCR      : L1CKCR_Register;
      --  Layerx Color Keying Configuration Register

      LPFCR      : L1PFCR_Register;
      --  Layerx Pixel Format Configuration Register

      LCACR      : L1CACR_Register;
      --  Layerx Constant Alpha Configuration Register

      LDCCR      : L1DCCR_Register;
      --  Layerx Default Color Configuration Register

      LBFCR      : L1BFCR_Register;
      --  Layerx Blending Factors Configuration Register

      Reserved_0 : Word;
      Reserved_1 : Word;

      LCFBAR     : Word;
      --  Layerx Color Frame Buffer Address Register

      LCFBLR     : L1CFBLR_Register;
      --  Layerx Color Frame Buffer Length Register

      LCFBLNR    : L1CFBLNR_Register;
      --  Layerx ColorFrame Buffer Line Number Register

      Reserved_2 : Word;
      Reserved_3 : Word;
      Reserved_4 : Word;

      LCLUTWR    : L1CLUTWR_Register;
      --  Layerx CLUT Write Register
   end record with Volatile;

   for Layer_Type use record
      LCR        at  0 range 0 .. 31;
      LWHPCR     at  4 range 0 .. 31;
      LWVPCR     at  8 range 0 .. 31;
      LCKCR      at 12 range 0 .. 31;
      LPFCR      at 16 range 0 .. 31;
      LCACR      at 20 range 0 .. 31;
      LDCCR      at 24 range 0 .. 31;
      LBFCR      at 28 range 0 .. 31;
      Reserved_0 at 32 range 0 .. 31;
      Reserved_1 at 36 range 0 .. 31;
      LCFBAR     at 40 range 0 .. 31;
      LCFBLR     at 44 range 0 .. 31;
      LCFBLNR    at 48 range 0 .. 31;
      Reserved_2 at 52 range 0 .. 31;
      Reserved_3 at 56 range 0 .. 31;
      Reserved_4 at 60 range 0 .. 31;
      LCLUTWR    at 64 range 0 .. 31;
   end record;
   type Layer_Access is access all Layer_Type;

   BF1_Constant_Alpha : constant := 2#100#;
   BF2_Constant_Alpha : constant := 2#101#;
   BF1_Pixel_Alpha    : constant := 2#110#;
   BF2_Pixel_Alpha    : constant := 2#111#;

   G_Layer1_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L1CR'Address;
   G_Layer2_Reg : aliased Layer_Type
     with Import, Address => LTDC_Periph.L2CR'Address;

   function Get_Layer (Layer : LCD_Layer) return Layer_Access;
   --  Retrieve the layer's registers

   protected Sync is
      --  Apply pending buffers on Vertical Sync. Caller must call Wait
      --  afterwards.
      procedure Apply_On_VSync;

      --  Wait for an interrupt.
      entry Wait;

      procedure Interrupt;
      pragma Attach_Handler
        (Interrupt, Ada.Interrupts.Names.LCD_TFT_Interrupt);

   private
      Not_Pending : Boolean := True;
   end Sync;

   ----------
   -- Sync --
   ----------

   protected body Sync is

      ----------
      -- Wait --
      ----------

      entry Wait when Not_Pending is
      begin
         null;
      end Wait;

      --------------------
      -- Apply_On_VSync --
      --------------------

      procedure Apply_On_VSync is
      begin
         Not_Pending := False;
         --  Enable the Register Refresh interrupt
         LTDC_Periph.IER.RRIE := True;
         --  And tell the LTDC to apply the layer registers on refresh
         LTDC_Periph.SRCR.VBR := True;
      end Apply_On_VSync;

      ---------------
      -- Interrupt --
      ---------------

      procedure Interrupt
      is
      begin
         if LTDC_Periph.ISR.RRIF then
            LTDC_Periph.IER.RRIE := False;
            LTDC_Periph.ICR.CRRIF  := True;

            Not_Pending := True;
         end if;
      end Interrupt;
   end Sync;

   ---------------
   -- Get_Layer --
   ---------------

   function Get_Layer (Layer : LCD_Layer) return Layer_Access is
   begin
      if Layer = Layer1 then
         return G_Layer1_Reg'Access;
      else
         return G_Layer2_Reg'Access;
      end if;
   end Get_Layer;

   -------------------
   -- Reload_Config --
   -------------------

   procedure Reload_Config
     (Immediate : Boolean := False)
   is
   begin
      if Immediate then
         LTDC_Periph.SRCR.IMR := True;

         loop
            exit when not LTDC_Periph.SRCR.IMR;
         end loop;
      else
         Sync.Apply_On_VSync;
         Sync.Wait;
      end if;
   end Reload_Config;

   ---------------------
   -- Set_Layer_State --
   ---------------------

   procedure Set_Layer_State
     (Layer   : LCD_Layer;
      Enabled : Boolean)
   is
      L   : constant Layer_Access := Get_Layer (Layer);
   begin
      if L.LCR.LEN /= Enabled then
         L.LCR.LEN := Enabled;
         Reload_Config (Immediate => True);
      end if;
   end Set_Layer_State;

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

   procedure Initialize
     (Width         : Positive;
      Height        : Positive;
      H_Sync        : Natural;
      H_Back_Porch  : Natural;
      H_Front_Porch : Natural;
      V_Sync        : Natural;
      V_Back_Porch  : Natural;
      V_Front_Porch : Natural;
      PLLSAI_N      : UInt9;
      PLLSAI_R      : UInt3;
      DivR          : Natural)
   is
      DivR_Val : PLLSAI_DivR;

   begin
      if Initialized then
         return;
      end if;

      if DivR = 2 then
         DivR_Val := PLLSAI_DIV2;
      elsif DivR = 4 then
         DivR_Val := PLLSAI_DIV4;
      elsif DivR = 8 then
         DivR_Val := PLLSAI_DIV8;
      elsif DivR = 16 then
         DivR_Val := PLLSAI_DIV16;
      else
         raise Constraint_Error with "Invalid DivR value: 2, 4, 8, 16 allowed";
      end if;

      Disable_PLLSAI;

      RCC_Periph.APB2ENR.LTDCEN := True;

      LTDC_Periph.GCR.VSPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.HSPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.DEPOL := To_Bool (Polarity_Active_Low);
      LTDC_Periph.GCR.PCPOL := To_Bool (Inverted_Input_Pixel_Clock);

      Set_PLLSAI_Factors
        (LCD  => PLLSAI_R,
         VCO  => PLLSAI_N,
         DivR => DivR_Val);
      Enable_PLLSAI;

      --  Synchronization size
      LTDC_Periph.SSCR :=
        (HSW => SSCR_HSW_Field (H_Sync - 1),
         VSH => SSCR_VSH_Field (V_Sync - 1),
         others => <>);

      --  Accumulated Back Porch
      LTDC_Periph.BPCR :=
        (AHBP => BPCR_AHBP_Field (H_Sync + H_Back_Porch - 1),
         AVBP => BPCR_AVBP_Field (V_Sync + V_Back_Porch - 1),
         others => <>);

      --  Accumulated Active Width/Height
      LTDC_Periph.AWCR :=
        (AAW => AWCR_AAW_Field (H_Sync + H_Back_Porch + Width - 1),
         AAH => AWCR_AAH_Field (V_Sync + V_Back_Porch + Height - 1),
         others => <>);

      --  VTotal Width/Height
      LTDC_Periph.TWCR :=
        (TOTALW =>
           TWCR_TOTALW_Field
             (H_Sync + H_Back_Porch + Width + H_Front_Porch - 1),
         TOTALH =>
           TWCR_TOTALH_Field
             (V_Sync + V_Back_Porch + Height + V_Front_Porch - 1),
         others => <>);

      --  Background color to black
      LTDC_Periph.BCCR.BC := 0;

      LTDC_Periph.GCR.LTDCEN := True;
   end Initialize;

   -----------
   -- Start --
   -----------

   procedure Start is
   begin
      LTDC_Periph.GCR.LTDCEN := True;
   end Start;

   ----------
   -- Stop --
   ----------

   procedure Stop is
   begin
      LTDC_Periph.GCR.LTDCEN := False;
   end Stop;

   -----------------
   -- Initialized --
   -----------------

   function Initialized return Boolean is
   begin
      return LTDC_Periph.GCR.LTDCEN;
   end Initialized;

   ----------------
   -- Layer_Init --
   ----------------

   procedure Layer_Init
     (Layer          : LCD_Layer;
      Config         : Pixel_Format;
      Buffer         : System.Address;
      X, Y           : Natural;
      W, H           : Positive;
      Constant_Alpha : Byte := 255;
      BF             : Blending_Factor := BF_Pixel_Alpha_X_Constant_Alpha)
   is
      L        : constant Layer_Access := Get_Layer (Layer);
      CFBL     : L1CFBLR_Register := L.LCFBLR;
   begin
      --  Horizontal start and stop = sync + Back Porch
      L.LWHPCR :=
        (WHSTPOS => L1WHPCR_WHSTPOS_Field (LTDC_Periph.BPCR.AHBP) + 1 +
             L1WHPCR_WHSTPOS_Field (X),
         WHSPPOS => L1WHPCR_WHSPPOS_Field (LTDC_Periph.BPCR.AHBP) +
             L1WHPCR_WHSPPOS_Field (X + W),
         others  => <>);

      --  Vertical start and stop
      L.LWVPCR :=
        (WVSTPOS => LTDC_Periph.BPCR.AVBP + 1 + UInt11 (Y),
         WVSPPOS => LTDC_Periph.BPCR.AVBP + UInt11 (Y + H),
         others  => <>);

      L.LPFCR.PF := Pixel_Format'Enum_Rep (Config);

      L.LCACR.CONSTA := Constant_Alpha;

      L.LDCCR := (others => 0);

      case BF is
         when BF_Constant_Alpha =>
            L.LBFCR.BF1 := BF1_Constant_Alpha;
            L.LBFCR.BF2 := BF2_Constant_Alpha;
         when BF_Pixel_Alpha_X_Constant_Alpha =>
            L.LBFCR.BF1 := BF1_Pixel_Alpha;
            L.LBFCR.BF2 := BF2_Pixel_Alpha;
      end case;

      CFBL.CFBLL := UInt13 (W * Bytes_Per_Pixel (Config)) + 3;
      CFBL.CFBP := UInt13 (W * Bytes_Per_Pixel (Config));
      L.LCFBLR := CFBL;

      L.LCFBLNR.CFBLNBR := UInt11 (H);

      Set_Frame_Buffer (Layer, Buffer);

      L.LCR.LEN := True;
      Reload_Config (True);
   end Layer_Init;

   ----------------------
   -- Set_Frame_Buffer --
   ----------------------

   procedure Set_Frame_Buffer
     (Layer : LCD_Layer; Addr : Frame_Buffer_Access)
   is
      function To_Word is new Ada.Unchecked_Conversion
        (Frame_Buffer_Access, Word);
   begin
      if Layer = Layer1 then
         LTDC_Periph.L1CFBAR := To_Word (Addr);
      else
         LTDC_Periph.L2CFBAR := To_Word (Addr);
      end if;
   end Set_Frame_Buffer;

   ----------------------
   -- Get_Frame_Buffer --
   ----------------------

   function Get_Frame_Buffer
     (Layer : LCD_Layer)
      return Frame_Buffer_Access
   is
      L : constant Layer_Access := Get_Layer (Layer);
      function To_FBA is new Ada.Unchecked_Conversion
        (Word, Frame_Buffer_Access);
   begin
      return To_FBA (L.LCFBAR);
   end Get_Frame_Buffer;

   --------------------
   -- Set_Background --
   --------------------

   procedure Set_Background (R, G, B : Byte) is
      RShift : constant Word := Shift_Left (Word (R), 16);
      GShift : constant Word := Shift_Left (Word (G), 8);
   begin
      LTDC_Periph.BCCR.BC :=
        UInt24 (RShift) or UInt24 (GShift) or UInt24 (B);
   end Set_Background;

end STM32.LTDC;

Fix the initialization of the LTDC, not working properly on the F7.


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

with Ada.Strings.Unbounded;
with Ada.Streams.Stream_IO;

with Util.Test_Caller;

with Util.Streams.Files;
with Util.Streams.Texts;
package body Util.Streams.Texts.Tests is

   use Util.Tests;
   use Ada.Streams.Stream_IO;

   package Caller is new Util.Test_Caller (Test, "Streams.Texts");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Texts.Open, Read_Line, Close",
                       Test_Read_Line'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a text stream.
   --  ------------------------------
   procedure Test_Read_Line (T : in out Test) is
      Stream : aliased Files.File_Stream;
      Reader : Util.Streams.Texts.Reader_Stream;
      Count  : Natural := 0;
   begin
      Stream.Open (Name => "Makefile", Mode => In_File);
      Reader.Initialize (From => Stream'Unchecked_Access);

      while not Reader.Is_Eof loop
         declare
            Line : Ada.Strings.Unbounded.Unbounded_String;
         begin
            Reader.Read_Line (Line);
            Count := Count + 1;
         end;
      end loop;
      Stream.Close;
      T.Assert (Count > 100, "Too few lines read");
   end Test_Read_Line;

end Util.Streams.Texts.Tests;

-----------------------------------------------------------------------
--  streams.files.tests -- Unit tests for buffered streams
--  Copyright (C) 2012, 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.Strings.Unbounded;
with Ada.Streams.Stream_IO;

with Util.Test_Caller;

with Util.Streams.Files;
with Util.Streams.Texts;
package body Util.Streams.Texts.Tests is

   use Ada.Streams.Stream_IO;

   package Caller is new Util.Test_Caller (Test, "Streams.Texts");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Util.Streams.Texts.Open, Read_Line, Close",
                       Test_Read_Line'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test reading a text stream.
   --  ------------------------------
   procedure Test_Read_Line (T : in out Test) is
      Stream : aliased Files.File_Stream;
      Reader : Util.Streams.Texts.Reader_Stream;
      Count  : Natural := 0;
   begin
      Stream.Open (Name => "Makefile", Mode => In_File);
      Reader.Initialize (From => Stream'Unchecked_Access);

      while not Reader.Is_Eof loop
         declare
            Line : Ada.Strings.Unbounded.Unbounded_String;
         begin
            Reader.Read_Line (Line);
            Count := Count + 1;
         end;
      end loop;
      Stream.Close;
      T.Assert (Count > 100, "Too few lines read");
   end Test_Read_Line;

end Util.Streams.Texts.Tests;

Remove unused use Util.Tests clause

Remove unused use Util.Tests clause


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

with Util.Test_Caller;

with ASF.Tests;
with AWA.Users.Models;
with AWA.Tests.Helpers.Users;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Users.Tests");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Email     : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Helpers.Users.Initialize (Principal);

      Do_Get (Request, Reply, "/auth/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("password2", "asdf");
      Request.Set_Parameter ("firstName", "joe");
      Request.Set_Parameter ("lastName", "dalton");
      Request.Set_Parameter ("register", "1");
      Request.Set_Parameter ("register-button", "1");
      Do_Post (Request, Reply, "/auth/register.html", "create-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      --  Now, get the access key and simulate a click on the validation link.
      declare

         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/validate.html", "validate-user-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");
      end;

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

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

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Set_Application_Context;
      AWA.Tests.Helpers.Users.Create_User (Principal, "Joe@gmail.com");

      Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Email   : constant String := "Joe@gmail.com";
   begin
      Do_Get (Request, Reply, "/auth/lost-password.html", "lost-password-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      ASF.Tests.Assert_Redirect (T, "/asfunit/auth/login.html",
                                 Reply, "Invalid redirect after lost password");

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/reset-password.html", "reset-password-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

         --  Post the reset password
         Request.Set_Parameter ("password", "asd");
         Request.Set_Parameter ("reset-password", "1");
         Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
      end;
   end Test_Reset_Password_User;

end AWA.Users.Tests;

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

with Util.Test_Caller;

with ASF.Tests;
with AWA.Users.Models;
with AWA.Tests.Helpers.Users;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Users.Tests");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Email     : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Helpers.Users.Initialize (Principal);

      Do_Get (Request, Reply, "/auth/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("password2", "asdf");
      Request.Set_Parameter ("firstName", "joe");
      Request.Set_Parameter ("lastName", "dalton");
      Request.Set_Parameter ("register", "1");
      Request.Set_Parameter ("register-button", "1");
      Do_Post (Request, Reply, "/auth/register.html", "create-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      --  Now, get the access key and simulate a click on the validation link.
      declare

         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/validate.html", "validate-user-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");
      end;

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

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

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Set_Application_Context;
      AWA.Tests.Helpers.Users.Create_User (Principal, "Joe@gmail.com");

      Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Email   : constant String := "Joe@gmail.com";
   begin
      Do_Get (Request, Reply, "/auth/lost-password.html", "lost-password-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      ASF.Tests.Assert_Redirect (T, "/asfunit/auth/login.html",
                                 Reply, "Invalid redirect after lost password");

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Request.Set_Parameter ("password", "asd");
         Request.Set_Parameter ("reset-password", "1");
         Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
      end;
   end Test_Reset_Password_User;

end AWA.Users.Tests;

Update the unit test according to the lost password recovery process


-----------------------------------------------------------------------
--  babel-streams-tests - Unit tests for babel streams
--  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 Util.Test_Caller;
with Babel.Files.Buffers;
with Babel.Streams.Cached;
with Babel.Streams.Files;
with Babel.Streams.XZ;
package body Babel.Streams.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Streams.Read",
                       Test_Stream_Composition'Access);
   end Add_Tests;

   --  ------------------------------
   --  Stream copy, compression and decompression test.
   --  Create a compressed version of the source file and then decompress the result.
   --  The source file is then compared to the decompressed result and must match.
   --  ------------------------------
   procedure Do_Copy (T    : in out Test;
                      Pool : in out Babel.Files.Buffers.Buffer_Pool;
                      Src  : in String) is
      use type Babel.Files.Buffers.Buffer_Access;

      Src_Path : constant String := Util.Tests.Get_Path (Src);
      Dst_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result/" & Src & ".xz");
      Tst_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result/" & Src);
      Buffer   : Babel.Files.Buffers.Buffer_Access;
   begin
      --  Compress the 'configure' file into 'configure.xz' through the file+cache+xz+file streams.
      declare
         In_File  : aliased Babel.Streams.Files.Stream_Type;
         Out_File : aliased Babel.Streams.Files.Stream_Type;
         Cache    : aliased Babel.Streams.Cached.Stream_Type;
         Lz       : aliased Babel.Streams.XZ.Stream_Type;
      begin
         Pool.Get_Buffer (Buffer);
         In_File.Open (Src_Path, Buffer);
         Cache.Load (In_File, Pool);

         Pool.Get_Buffer (Buffer);
         Out_File.Create (Dst_Path, 8#644#);
         Lz.Set_Buffer (Buffer);
         Lz.Set_Output (Out_File'Unchecked_Access);
         loop
            Cache.Read (Buffer);
            exit when Buffer = null;
            Lz.Write (Buffer);
         end loop;
         Lz.Flush;
         Lz.Close;
      end;

      --  Decompress through file+cache+xz+file
      declare
         In_File  : aliased Babel.Streams.Files.Stream_Type;
         Out_File : aliased Babel.Streams.Files.Stream_Type;
         Cache    : aliased Babel.Streams.Cached.Stream_Type;
         Lz       : aliased Babel.Streams.XZ.Stream_Type;
      begin
         Pool.Get_Buffer (Buffer);
         In_File.Open (Dst_Path, Buffer);
         Cache.Load (In_File, Pool);

         --  Setup decompression.
         Pool.Get_Buffer (Buffer);
         Lz.Set_Input (Cache'Unchecked_Access);
         Lz.Set_Buffer (Buffer);

         Out_File.Create (Tst_Path, 8#644#);
         loop
            Lz.Read (Buffer);
            exit when Buffer = null;
            Out_File.Write (Buffer);
         end loop;
         Out_File.Close;
      end;
      Util.Tests.Assert_Equal_Files (T, Src_Path, Tst_Path,
                                     "Composition stream failed for: " & Src);

   end Do_Copy;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Stream_Composition (T : in out Test) is
      Pool     : aliased Babel.Files.Buffers.Buffer_Pool;
   begin
      Babel.Files.Buffers.Create_Pool (Into  => Pool,
                                       Size  => 1_000,
                                       Count => 1000);
      Do_Copy (T, Pool, "configure");
      Do_Copy (T, Pool, "babel.gpr");
      Do_Copy (T, Pool, "configure.in");
      Do_Copy (T, Pool, "config.guess");
      Do_Copy (T, Pool, "Makefile.in");
   end Test_Stream_Composition;

end Babel.Streams.Tests;

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

with Util.Test_Caller;
with Babel.Files.Buffers;
with Babel.Streams.Cached;
with Babel.Streams.Files;
with Babel.Streams.XZ;
package body Babel.Streams.Tests is

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

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test Babel.Streams.Read",
                       Test_Stream_Composition'Access);
   end Add_Tests;

   --  ------------------------------
   --  Stream copy, compression and decompression test.
   --  Create a compressed version of the source file and then decompress the result.
   --  The source file is then compared to the decompressed result and must match.
   --  ------------------------------
   procedure Do_Copy (T    : in out Test;
                      Pool : in out Babel.Files.Buffers.Buffer_Pool;
                      Src  : in String) is
      use type Babel.Files.Buffers.Buffer_Access;

      Src_Path : constant String := Util.Tests.Get_Path (Src);
      Dst_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result/" & Src & ".xz");
      Tst_Path : constant String := Util.Tests.Get_Test_Path ("regtests/result/" & Src);
      Buffer   : Babel.Files.Buffers.Buffer_Access;
   begin
      --  Compress the 'configure' file into 'configure.xz' through the file+cache+xz+file streams.
      declare
         In_File  : aliased Babel.Streams.Files.Stream_Type;
         Out_File : aliased Babel.Streams.Files.Stream_Type;
         Cache    : aliased Babel.Streams.Cached.Stream_Type;
         Lz       : aliased Babel.Streams.XZ.Stream_Type;
      begin
         Pool.Get_Buffer (Buffer);
         In_File.Open (Src_Path, Buffer);
         Cache.Load (In_File, Pool);

         Pool.Get_Buffer (Buffer);
         Out_File.Create (Dst_Path, 8#644#);
         Lz.Set_Buffer (Buffer);
         Lz.Set_Output (Out_File'Unchecked_Access);
         loop
            Cache.Read (Buffer);
            exit when Buffer = null;
            Lz.Write (Buffer);
         end loop;
         Lz.Flush;
         Lz.Close;
         lz.Finalize;
         Cache.Finalize;
         In_File.Finalize;
         Out_File.Finalize;
      end;

      --  Decompress through file+cache+xz+file
      declare
         In_File  : aliased Babel.Streams.Files.Stream_Type;
         Out_File : aliased Babel.Streams.Files.Stream_Type;
         Cache    : aliased Babel.Streams.Cached.Stream_Type;
         Lz       : aliased Babel.Streams.XZ.Stream_Type;
      begin
         Pool.Get_Buffer (Buffer);
         In_File.Open (Dst_Path, Buffer);
         Cache.Load (In_File, Pool);

         --  Setup decompression.
         Pool.Get_Buffer (Buffer);
         Lz.Set_Input (Cache'Unchecked_Access);
         Lz.Set_Buffer (Buffer);

         Out_File.Create (Tst_Path, 8#644#);
         loop
            Lz.Read (Buffer);
            exit when Buffer = null;
            Out_File.Write (Buffer);
         end loop;
         Out_File.Close;
         lz.Finalize;
         Cache.Finalize;
         In_File.Finalize;
         Out_File.Finalize;
      end;
      Util.Tests.Assert_Equal_Files (T, Src_Path, Tst_Path,
                                     "Composition stream failed for: " & Src);

   end Do_Copy;

   --  ------------------------------
   --  Test the Find function resolving some existing user.
   --  ------------------------------
   procedure Test_Stream_Composition (T : in out Test) is
      Pool     : aliased Babel.Files.Buffers.Buffer_Pool;
   begin
      Pool.Create_Pool (Size  => 1_000,
                        Count => 1000);
      Do_Copy (T, Pool, "configure");
      Do_Copy (T, Pool, "babel.gpr");
      Do_Copy (T, Pool, "configure.in");
      Do_Copy (T, Pool, "config.guess");
      Do_Copy (T, Pool, "Makefile.in");
   end Test_Stream_Composition;

end Babel.Streams.Tests;

Update the stream unit tests

Update the stream unit tests


-----------------------------------------------------------------------
--  ado-configs -- Database connection configuration
--  Copyright (C) 2010, 2011, 2012, 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 Util.Properties;

package ADO.Configs is

   --  Configuration property to control the search paths to load XML queries.
   QUERY_PATHS_CONFIG : constant String := "ado.queries.paths";

   --  Configuration property to control whether all the program XML queries must be
   --  loaded when the database configuration is setup.
   QUERY_LOAD_CONFIG  : constant String := "ado.queries.load";

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new Ada.Finalization.Controlled with private;
   type Configuration_Access is access all Configuration'Class;

   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   procedure Set_Connection (Config : in out Configuration;
                             URI    : in String);

   --  Get the connection URI that describes the database connection string.
   --  The returned string may contain connection authentication information.
   function Get_URI (Config : in Configuration) return String;

   --  Get the connection URI that describes the database connection string
   --  but the connection authentication is replaced by XXXX.
   function Get_Log_URI (Config : in Configuration) return String;

   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   procedure Set_Property (Config : in out Configuration;
                           Name   : in String;
                           Value  : in String);

   --  Get a property from the data source configuration.
   --  If the property does not exist, an empty string is returned.
   function Get_Property (Config : in Configuration;
                          Name   : in String) return String;

   --  Set the server hostname.
   procedure Set_Server (Config : in out Configuration;
                         Server : in String);

   --  Get the server hostname.
   function Get_Server (Config : in Configuration) return String;

   --  Set the server port.
   procedure Set_Port (Config : in out Configuration;
                       Port   : in Natural);

   --  Get the server port.
   function Get_Port (Config : in Configuration) return Natural;

   --  Set the database name.
   procedure Set_Database (Config   : in out Configuration;
                           Database : in String);

   --  Get the database name.
   function Get_Database (Config : in Configuration) return String;

   --  Get the database driver name.
   function Get_Driver (Config : in Configuration) return String;

   --  Iterate over the configuration properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Config  : in Configuration;
                      Process : access procedure (Name : in String;
                                                  Item : in Util.Properties.Value));

private

   use Ada.Strings.Unbounded;

   type Configuration is new Ada.Finalization.Controlled with record
      URI        : Unbounded_String;
      Log_URI    : Unbounded_String;
      Driver     : Unbounded_String;
      Server     : Unbounded_String;
      Port       : Natural := 0;
      Database   : Unbounded_String;
      Properties : Util.Properties.Manager;
   end record;

end ADO.Configs;

-----------------------------------------------------------------------
--  ado-configs -- Database connection configuration
--  Copyright (C) 2010, 2011, 2012, 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 Util.Properties;

package ADO.Configs is

   --  Configuration property to control the search paths to load XML queries.
   QUERY_PATHS_CONFIG : constant String := "ado.queries.paths";

   --  Configuration property to control whether all the program XML queries must be
   --  loaded when the database configuration is setup.
   QUERY_LOAD_CONFIG  : constant String := "ado.queries.load";

   --  Configuration property to enable or disable the dynamic load of database driver.
   DYNAMIC_DRIVER_LOAD : constant String := "ado.drivers.load";

   --  Raised when the connection URI is invalid.
   Connection_Error : exception;

   --  ------------------------------
   --  The database configuration properties
   --  ------------------------------
   type Configuration is new Ada.Finalization.Controlled with private;
   type Configuration_Access is access all Configuration'Class;

   --  Set the connection URL to connect to the database.
   --  The driver connection is a string of the form:
   --
   --   driver://[host][:port]/[database][?property1][=value1]...
   --
   --  If the string is invalid or if the driver cannot be found,
   --  the Connection_Error exception is raised.
   procedure Set_Connection (Config : in out Configuration;
                             URI    : in String);

   --  Get the connection URI that describes the database connection string.
   --  The returned string may contain connection authentication information.
   function Get_URI (Config : in Configuration) return String;

   --  Get the connection URI that describes the database connection string
   --  but the connection authentication is replaced by XXXX.
   function Get_Log_URI (Config : in Configuration) return String;

   --  Set a property on the datasource for the driver.
   --  The driver can retrieve the property to configure and open
   --  the database connection.
   procedure Set_Property (Config : in out Configuration;
                           Name   : in String;
                           Value  : in String);

   --  Get a property from the data source configuration.
   --  If the property does not exist, an empty string is returned.
   function Get_Property (Config : in Configuration;
                          Name   : in String) return String;

   --  Set the server hostname.
   procedure Set_Server (Config : in out Configuration;
                         Server : in String);

   --  Get the server hostname.
   function Get_Server (Config : in Configuration) return String;

   --  Set the server port.
   procedure Set_Port (Config : in out Configuration;
                       Port   : in Natural);

   --  Get the server port.
   function Get_Port (Config : in Configuration) return Natural;

   --  Set the database name.
   procedure Set_Database (Config   : in out Configuration;
                           Database : in String);

   --  Get the database name.
   function Get_Database (Config : in Configuration) return String;

   --  Get the database driver name.
   function Get_Driver (Config : in Configuration) return String;

   --  Iterate over the configuration properties and execute the given procedure passing the
   --  property name and its value.
   procedure Iterate (Config  : in Configuration;
                      Process : access procedure (Name : in String;
                                                  Item : in Util.Properties.Value));

private

   use Ada.Strings.Unbounded;

   type Configuration is new Ada.Finalization.Controlled with record
      URI        : Unbounded_String;
      Log_URI    : Unbounded_String;
      Driver     : Unbounded_String;
      Server     : Unbounded_String;
      Port       : Natural := 0;
      Database   : Unbounded_String;
      Properties : Util.Properties.Manager;
   end record;

end ADO.Configs;

Declare DYNAMIC_DRIVER_LOAD configuration parameter


------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Command_Line;
with Ada.Text_IO;
with AWS.Config;
with AWS.Server;
with Common;
with Natools.Web.Sites;
with Syslog.Guess.App_Name;
with Syslog.Guess.Hostname;
with Syslog.Transport.Send_Task;
with Syslog.Transport.UDP;

procedure Simple_Site is
   WS : AWS.Server.HTTP;
   Debug : constant Boolean := Ada.Command_Line.Argument_Count >= 2;
begin
   if Debug then
      Natools.Web.Log := Common.Text_IO_Log'Access;
   else
      Syslog.Guess.App_Name;
      Syslog.Guess.Hostname;
      Syslog.Transport.UDP.Connect ("127.0.0.1");
      Syslog.Transport.Send_Task.Set_Backend (Syslog.Transport.UDP.Transport);
      Syslog.Set_Transport (Syslog.Transport.Send_Task.Transport);
      Syslog.Set_Default_Facility (Syslog.Facilities.Daemon);
      Natools.Web.Log := Common.Syslog_Log'Access;
   end if;

   if Ada.Command_Line.Argument_Count >= 1 then
      Natools.Web.Sites.Reset
        (Common.Site'Access, Ada.Command_Line.Argument (1));
   else
      Natools.Web.Sites.Reset (Common.Site'Access, "site.sx");
   end if;

   AWS.Server.Start (WS, Common.Respond'Access, AWS.Config.Get_Current);

   if Debug then
      Ada.Text_IO.Put_Line ("Websever started");
      AWS.Server.Wait (AWS.Server.Q_Key_Pressed);
   else
      AWS.Server.Wait;
   end if;

   AWS.Server.Shutdown (WS);
end Simple_Site;

------------------------------------------------------------------------------
-- Copyright (c) 2014, Natacha Porté                                        --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

with Ada.Command_Line;
with Ada.Directories;
with Ada.Text_IO;
with AWS.Config;
with AWS.Server;
with Common;
with Natools.Web.Sites;
with Syslog.Guess.App_Name;
with Syslog.Guess.Hostname;
with Syslog.Transport.Send_Task;
with Syslog.Transport.UDP;

procedure Simple_Site is
   WS : AWS.Server.HTTP;
   Debug : constant Boolean := Ada.Command_Line.Argument_Count >= 2;
begin
   if Debug then
      Natools.Web.Log := Common.Text_IO_Log'Access;
   else
      Syslog.Guess.App_Name;
      Syslog.Guess.Hostname;
      Syslog.Transport.UDP.Connect ("127.0.0.1");
      Syslog.Transport.Send_Task.Set_Backend (Syslog.Transport.UDP.Transport);
      Syslog.Set_Transport (Syslog.Transport.Send_Task.Transport);
      Syslog.Set_Default_Facility (Syslog.Facilities.Daemon);
      Natools.Web.Log := Common.Syslog_Log'Access;
   end if;

   if Ada.Command_Line.Argument_Count >= 1 then
      Natools.Web.Sites.Reset
        (Common.Site'Access, Ada.Command_Line.Argument (1));
   else
      Natools.Web.Sites.Reset (Common.Site'Access, "site.sx");
   end if;

   AWS.Server.Start (WS, Common.Respond'Access, AWS.Config.Get_Current);

   if not Debug then
      AWS.Server.Wait;
   elsif Ada.Directories.Exists (Ada.Command_Line.Argument (2)) then
      Ada.Text_IO.Put_Line ("Websever started, waiting for removal of "
        & Ada.Command_Line.Argument (2));
      loop
         delay 1.0;
         exit when not Ada.Directories.Exists (Ada.Command_Line.Argument (2));
      end loop;
   else
      Ada.Text_IO.Put_Line ("Websever started, waiting for Q press");
      AWS.Server.Wait (AWS.Server.Q_Key_Pressed);
   end if;

   AWS.Server.Shutdown (WS);
end Simple_Site;

simple_site: add an option to drive program termination through file deletion


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

with System;

with Util.Streams.Buffered;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
package MAT.Readers is

   type Buffer_Type is private;
   type Buffer_Ptr is access all Buffer_Type;

   type Message_Type is record
      Kind   : MAT.Events.Event_Type;
      Size   : Natural;
      Buffer : Buffer_Ptr;
   end record;
   subtype Message is Message_Type;

   -----------------
   --  Ipc Client Manager
   -----------------
   --  The Manager is a kind of object adapter. It registers a collection
   --  of servants and dispatches incomming messages to those servants.
   type Manager_Base is abstract new Ada.Finalization.Limited_Controlled with private;
   type Manager is access all Manager_Base'Class;

   --  Initialize the manager instance.
   overriding
   procedure Initialize (Manager : in out Manager_Base);

   --  Register the reader to handle the event identified by the given name.
   --  The event is mapped to the given id and the attributes table is used
   --  to setup the mapping from the data stream attributes.
   procedure Register_Reader (Into   : in out Manager_Base;
                              Reader : in Reader_Access;
                              Name   : in String;
                              Id     : in MAT.Events.Internal_Reference;
                              Model  : in MAT.Events.Const_Attribute_Table_Access);

   procedure Dispatch_Message (Client : in out Manager_Base;
                               Msg    : in out Message);

   --  Read a message from the stream.
   procedure Read_Message (Client : in out Manager_Base;
                           Msg    : in out Message) is abstract;

   --  Read a list of event definitions from the stream and configure the reader.
   procedure Read_Event_Definitions (Client : in out Manager_Base;
                                     Msg    : in out Message);

   --  Get the target events.
   function Get_Target_Events (Client : in Manager_Base)
                               return MAT.Events.Targets.Target_Events_Access;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List   : in out Reader_List_Type;
                         Reader : in out Manager_Base'Class) is abstract;

private

   type Endian_Type is (BIG_ENDIAN, LITTLE_ENDIAN);

   type Buffer_Type is record
      Current : System.Address;
      Start   : System.Address;
      Last    : System.Address;
      Buffer  : Util.Streams.Buffered.Buffer_Access;
      Size    : Natural;
      Total   : Natural;
      Endian  : Endian_Type := LITTLE_ENDIAN;
   end record;

   type Reader_Base is abstract tagged limited record
      Owner : Manager := null;
   end record;

   --  Record a servant
   type Message_Handler is record
      For_Servant : Reader_Access;
      Id          : MAT.Events.Internal_Reference;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   use type MAT.Types.Uint16;

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

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Message_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Manager_Base is abstract new Ada.Finalization.Limited_Controlled with record
      Readers     : Reader_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
   end record;

   --  Read the event data stream headers with the event description.
   --  Configure the reader to analyze the data stream according to the event descriptions.
   procedure Read_Headers (Client : in out Manager_Base;
                           Msg    : in out Message);

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message);

end MAT.Readers;

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

with System;

with Util.Streams.Buffered;

with MAT.Types;
with MAT.Events;
with MAT.Events.Targets;
package MAT.Readers is

   type Buffer_Type is private;
   type Buffer_Ptr is access all Buffer_Type;

   type Message_Type is record
      Kind   : MAT.Events.Event_Type;
      Size   : Natural;
      Buffer : Buffer_Ptr;
   end record;
   subtype Message is Message_Type;

   type Reader_List_Type is limited interface;
   type Reader_List_Type_Access is access all Reader_List_Type'Class;

   --  Initialize the target object to manage the memory slots, the stack frames
   --  and setup the reader to analyze the memory and other events.
   procedure Initialize (List   : in out Reader_List_Type;
                         Reader : in out Manager_Base'Class) is abstract;

private

   type Endian_Type is (BIG_ENDIAN, LITTLE_ENDIAN);

   type Buffer_Type is record
      Current : System.Address;
      Start   : System.Address;
      Last    : System.Address;
      Buffer  : Util.Streams.Buffered.Buffer_Access;
      Size    : Natural;
      Total   : Natural;
      Endian  : Endian_Type := LITTLE_ENDIAN;
   end record;

   type Reader_Base is abstract tagged limited record
      Owner : Manager := null;
   end record;

   --  Record a servant
   type Message_Handler is record
      For_Servant : Reader_Access;
      Id          : MAT.Events.Internal_Reference;
      Attributes  : MAT.Events.Const_Attribute_Table_Access;
      Mapping     : MAT.Events.Attribute_Table_Ptr;
   end record;

   function Hash (Key : in MAT.Types.Uint16) return Ada.Containers.Hash_Type;

   use type MAT.Types.Uint16;

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

   --  Runtime handlers associated with the events.
   package Handler_Maps is
     new Ada.Containers.Hashed_Maps (Key_Type     => MAT.Types.Uint16,
                                     Element_Type => Message_Handler,
                                     Hash         => Hash,
                                     Equivalent_Keys => "=");

   type Manager_Base is abstract new Ada.Finalization.Limited_Controlled with record
      Readers     : Reader_Maps.Map;
      Handlers    : Handler_Maps.Map;
      Version     : MAT.Types.Uint16;
      Flags       : MAT.Types.Uint16;
      Probe       : MAT.Events.Attribute_Table_Ptr;
      Frame       : access MAT.Events.Frame_Info;
      Events      : MAT.Events.Targets.Target_Events_Access;
   end record;

   --  Read the event data stream headers with the event description.
   --  Configure the reader to analyze the data stream according to the event descriptions.
   procedure Read_Headers (Client : in out Manager_Base;
                           Msg    : in out Message);

   --  Read an event definition from the stream and configure the reader.
   procedure Read_Definition (Client : in out Manager_Base;
                              Msg    : in out Message);

end MAT.Readers;

Remove the Manager_Base type (now replaced by MAT.Events.Probes)


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

with Util.Test_Caller;

with ASF.Tests;
with AWA.Users.Models;
with AWA.Tests.Helpers.Users;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Users.Tests");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Email     : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Helpers.Users.Initialize (Principal);

      Do_Get (Request, Reply, "/auth/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("password2", "asdf");
      Request.Set_Parameter ("firstName", "joe");
      Request.Set_Parameter ("lastName", "dalton");
      Request.Set_Parameter ("register", "1");
      Request.Set_Parameter ("register-button", "1");
      Do_Post (Request, Reply, "/auth/register.html", "create-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      --  Now, get the access key and simulate a click on the validation link.
      declare

         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/validate.html", "validate-user-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");
      end;

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

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

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Set_Application_Context;
      AWA.Tests.Helpers.Users.Create_User (Principal, "Joe@gmail.com");

      Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Email   : constant String := "Joe@gmail.com";
   begin
      Do_Get (Request, Reply, "/auth/lost-password.html", "lost-password-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/reset-password.html", "reset-password-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

         --  Post the reset password
         Request.Set_Parameter ("password", "asd");
         Request.Set_Parameter ("reset-password", "1");
         Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
      end;
   end Test_Reset_Password_User;

end AWA.Users.Tests;

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

with Util.Test_Caller;

with ASF.Tests;
with AWA.Users.Models;
with AWA.Tests.Helpers.Users;

with ASF.Requests.Mockup;
with ASF.Responses.Mockup;
with ASF.Principals;
package body AWA.Users.Tests is

   use ASF.Tests;
   use AWA.Tests;

   package Caller is new Util.Test_Caller (Test, "Users.Tests");

   procedure Add_Tests (Suite : in Util.Tests.Access_Test_Suite) is
   begin
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Create_User (/users/register.xhtml)",
                       Test_Create_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Close_Session",
                       Test_Logout_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Tests.Login_User (/users/login.xhtml)",
                       Test_Login_User'Access);
      Caller.Add_Test (Suite, "Test AWA.Users.Services.Lost_Password, Reset_Password",
                       Test_Reset_Password_User'Access);
   end Add_Tests;

   --  ------------------------------
   --  Test creation of user by simulating web requests.
   --  ------------------------------
   procedure Test_Create_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Email     : constant String := "Joe-" & Util.Tests.Get_Uuid & "@gmail.com";
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Helpers.Users.Initialize (Principal);

      Do_Get (Request, Reply, "/auth/register.html", "create-user-1.html");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("password", "asdf");
      Request.Set_Parameter ("password2", "asdf");
      Request.Set_Parameter ("firstName", "joe");
      Request.Set_Parameter ("lastName", "dalton");
      Request.Set_Parameter ("register", "1");
      Request.Set_Parameter ("register-button", "1");
      Do_Post (Request, Reply, "/auth/register.html", "create-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      --  Now, get the access key and simulate a click on the validation link.
      declare

         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/validate.html", "validate-user-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");
      end;

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Create_User;

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

   --  ------------------------------
   --  Test user authentication by simulating a web request.
   --  ------------------------------
   procedure Test_Login_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request   : ASF.Requests.Mockup.Request;
      Reply     : ASF.Responses.Mockup.Response;
      Principal : AWA.Tests.Helpers.Users.Test_User;
   begin
      AWA.Tests.Set_Application_Context;
      AWA.Tests.Helpers.Users.Create_User (Principal, "Joe@gmail.com");

      Do_Get (Request, Reply, "/auth/login.html", "login-user-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      --  Check that the user is NOT logged.
      T.Assert (Request.Get_User_Principal = null, "A user principal should not be defined");

      Request.Set_Parameter ("email", "Joe@gmail.com");
      Request.Set_Parameter ("password", "admin");
      Request.Set_Parameter ("login", "1");
      Request.Set_Parameter ("login-button", "1");
      Do_Post (Request, Reply, "/auth/login.html", "login-user-2.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

      --  Check that the user is logged and we have a user principal now.
      T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
   end Test_Login_User;

   --  ------------------------------
   --  Test the reset password by simulating web requests.
   --  ------------------------------
   procedure Test_Reset_Password_User (T : in out Test) is
      use type ASF.Principals.Principal_Access;

      Request : ASF.Requests.Mockup.Request;
      Reply   : ASF.Responses.Mockup.Response;
      Email   : constant String := "Joe@gmail.com";
   begin
      Do_Get (Request, Reply, "/auth/lost-password.html", "lost-password-1.html");

      T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

      Request.Set_Parameter ("email", Email);
      Request.Set_Parameter ("lost-password", "1");
      Request.Set_Parameter ("lost-password-button", "1");
      Do_Post (Request, Reply, "/auth/lost-password.html", "lost-password-2.html");

      ASF.Tests.Assert_Redirect (T, "/asfunit/auth/login.html",
                                 Reply, "Invalid redirect after lost password");

      --  Now, get the access key and simulate a click on the reset password link.
      declare
         Principal : AWA.Tests.Helpers.Users.Test_User;
         Key       : AWA.Users.Models.Access_Key_Ref;
      begin
         AWA.Tests.Set_Application_Context;
         AWA.Tests.Helpers.Users.Find_Access_Key (Principal, Email, Key);
         T.Assert (not Key.Is_Null, "There is no access key associated with the user");

         --  Simulate user clicking on the reset password link.
         --  This verifies the key, login the user and redirect him to the change-password page
         Request.Set_Parameter ("key", Key.Get_Access_Key);
         Do_Get (Request, Reply, "/auth/reset-password.html", "reset-password-1.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_MOVED_TEMPORARILY, "Invalid response");

         --  Post the reset password
         Request.Set_Parameter ("password", "asd");
         Request.Set_Parameter ("reset-password", "1");
         Do_Post (Request, Reply, "/auth/change-password.html", "reset-password-2.html");

         T.Assert (Reply.Get_Status = ASF.Responses.SC_OK, "Invalid response");

         --  Check that the user is logged and we have a user principal now.
         T.Assert (Request.Get_User_Principal /= null, "A user principal should be defined");
      end;
   end Test_Reset_Password_User;

end AWA.Users.Tests;

Fix unit test: after the lost password form submission, we are redirected to the login page